shorten_names = function(x, n) {
x = head(x ,n)
bn = basename(x)
here = paste0(normalizePath("."), .Platform$file.sep, bn)
clean = gsub("\"", "", bn)
if (any(x != here))
paste0("[...]", .Platform$file.sep, clean)
else
clean
}
#' @export
print.stars_proxy = function(x, ..., n = 1e5, nfiles = 10, simplify = TRUE) {
if (!is.null(attr(x, "resolutions")))
cat("multi-resolution ")
cat("stars_proxy object with", length(x),
if (length(x) > 1) "attributes" else "attribute",
"in", sum(lengths(x)), "file(s)")
if (length(x[[1]]) > nfiles)
cat("; showing the first", min(length(x[[1]]), nfiles), "filenames\n")
else
cat(":\n")
names = lapply(x, function(nm) if (is.function(nm)) nm() else nm)
if (simplify)
print(lapply(names, shorten_names, n = nfiles))
else
print(lapply(names, head, n = nfiles))
if (!is.null(attr(x, "NA_value")) && !is.na(attr(x, "NA_value")))
cat("NA_value: ", attr(x, "NA_value"), "\n")
cat("dimension(s):\n")
print(st_dimensions(x), ...)
if (!is.null(attr(x, "call_list"))) {
cat("call_list:\n")
print(unlist(attr(x, "call_list")))
cat("This object has pending lazy operations: dimensions as printed may not reflect this.\n")
}
}
#' @export
dim.stars_proxy = function(x) {
dim(st_dimensions(x))
}
#' @export
as.data.frame.stars_proxy = function(x, ...) {
as.data.frame(st_as_stars(x), ...)
}
#' @name plot
#' @export
#' @details when plotting a subsetted \code{stars_proxy} object, the default value for argument \code{downsample} will not be computed correctly, and has to be set manually.
plot.stars_proxy = function(x, y, ..., downsample = get_downsample(dim(x))) {
plot(st_as_stars(x, downsample = downsample, ...), ..., downsample = 0)
}
st_stars_proxy = function(x, dimensions, ..., NA_value, resolutions, RasterIO = list(), file_dim = NULL) {
stopifnot(!missing(NA_value))
stopifnot(!missing(resolutions))
stopifnot(length(list(...)) == 0)
stopifnot(is.list(x))
stopifnot(inherits(dimensions, "dimensions"))
if (length(RasterIO) == 0)
RasterIO = NULL
structure(x, dimensions = dimensions, NA_value = NA_value, resolutions = resolutions,
RasterIO = RasterIO, file_dim = file_dim, class = c("stars_proxy", "stars"))
}
add_resolution = function(lst) {
n = length(lst)
resolutions = data.frame(x = numeric(n), y = numeric(n))
for (i in seq_along(lst)) {
d = st_dimensions(lst[[i]])
xy = attr(d, "raster")$dimensions
resolutions[i,] = c(d[[ xy[1] ]]$delta, d[[ xy[2] ]]$delta)
}
rownames(resolutions) = sapply(lst, names)
structure(lst, resolutions = resolutions)
}
#' @export
#' @param along_crs logical; if \code{TRUE}, combine arrays along a CRS dimension
#' @name c.stars
c.stars_proxy = function(..., along = NA_integer_, along_crs = FALSE, try_hard = FALSE,
nms = names(list(...)), tolerance = sqrt(.Machine$double.eps)) {
dots = list(...)
get_file_dim = function(dots) {
do.call(rbind, lapply(dots, attr, "file_dim"))
}
if (!all(sapply(dots, function(x) inherits(x, "stars_proxy"))))
stop("all arguments to c() should be stars_proxy objects")
rio = attr(dots[[1]], "RasterIO")
# Case 1: merge attributes of several objects by simply putting them together in a single stars object;
# dim does not change:
if (length(dots) == 1 && length(along) == 1 && is.na(along)) # do nothing
dots[[1]]
else if (along_crs)
combine_along_crs_proxy(dots)
else if (identical(along, NA_integer_)) {
if (identical_dimensions(dots))
st_stars_proxy(setNamesIfnn(do.call(c, lapply(dots, unclass)), nms),
dimensions = st_dimensions(dots[[1]]),
NA_value = attr(dots[[1]], "NA_value"),
resolutions = NULL,
file_dim = get_file_dim(dots),
RasterIO = rio)
else if (identical_dimensions(dots, ignore_resolution = TRUE, tolerance = tolerance)) {
dots = add_resolution(dots)
st_stars_proxy(setNamesIfnn(do.call(c, lapply(dots, unclass)), nms),
dimensions = st_dimensions(dots[[1]]),
resolutions = attr(dots, "resolutions"),
NA_value = attr(dots[[1]], "NA_value"),
file_dim = get_file_dim(dots),
RasterIO = rio)
} else {
# currently catches only the special case of ... being a broken up time series:
along = sort_out_along(dots)
if (!is.na(along))
do.call(c, c(dots, along = along))
else if (!try_hard)
stop("don't know how to merge arrays: please specify parameter along")
else {
d = lapply(dots, st_dimensions)
ident = c(TRUE, sapply(d[-1], identical, d[[1]]))
if (!all(ident))
warning(paste(
"ignored subdataset(s) with dimensions different from first subdataset:",
paste(which(!ident), collapse = ", "),
"\nuse gdal_subdatasets() to find all subdataset names"))
if (!is.null(nms))
nms = nms[ident]
st_stars_proxy(setNamesIfnn(do.call(c, lapply(dots[ident], unclass)), nms),
dimensions = st_dimensions(dots[[1]]),
NA_value = attr(dots[[1]], "NA_value"),
resolutions = NULL,
file_dim = get_file_dim(dots),
RasterIO = rio)
}
}
} else { # arrange along "along" dimension:
if (is.list(along)) { # custom ordering of ... over dimension(s) with values specified
stop("for proxy objects, along argument as list is not implemented")
} else { # loop over attributes, abind them:
# along_dim: the number of the dimension along which we merge arrays
d = st_dimensions(dots[[1]])
along_dim = if (is.character(along)) {
along_dim = which(along == names(d))
if (length(along_dim) == 0)
length(d) + 1
else
along_dim
} else
along
# ret = propagate_units(mapply(abind, ..., along = along_dim, SIMPLIFY = FALSE), dots[[1]])
ret = if (length(dots[[1]]) == 1)
list(attr = unlist(do.call(c, lapply(dots, unclass))))
else {
m = mapply(c, lapply(dots, unclass)) # simplifies to list matrix
setNames(lapply(seq_len(nrow(m)), function(i) unlist(m[i,])), names(dots[[1]]))
}
dims = combine_dimensions(dots, along_dim)
if (along_dim == length(d) + 1)
names(dims)[along_dim] = if (is.character(along)) along else "new_dim"
st_stars_proxy(ret, dimensions = dims, NA_value = attr(dots[[1]], "NA_value"),
resolutions = NULL,
file_dim = get_file_dim(dots),
RasterIO = rio)
}
}
}
combine_along_crs_proxy = function(dots) {
crs = lapply(l, st_crs)
l = lapply(dots, st_set_crs, value = NA)
ret = do.call(c, c(l, along = "crs"))
st_set_dimensions(ret, "crs", values = crs, point = TRUE)
}
#' @export
#' @name redimension
st_redimension.stars_proxy = function(x, new_dims = st_dimensions(x), along = list(new_dim = names(x)), ...) {
d = st_dimensions(x)
new_dim = create_dimension(values = along[[1]])
dims = create_dimensions(c(d, new_dim = list(new_dim)), attr(d, "raster"))
names(dims)[names(dims) == "new_dim"] = names(along)
ret = list(unlist(do.call(c, lapply(x, unclass))))
st_stars_proxy(setNames(ret, paste(names(x), collapse = ".")), dimensions = dims,
NA_value = attr(x, "NA_value"), resolutions = attr(x, "resolutions"))
}
# fetch a stars object from a stars_proxy object, using downsampling
fetch = function(x, downsample = 0, ...) {
stopifnot(inherits(x, "stars_proxy"))
d = st_dimensions(x)
xy = attr(d, "raster")$dimensions
dx = d[[ xy[1] ]]
dy = d[[ xy[2] ]]
nBufXSize = nXSize = dx$to - dx$from + 1
nBufYSize = nYSize = dy$to - dy$from + 1
downsample = rep(downsample, length.out = 2)
if (downsample[1] > 0)
nBufXSize = ceiling(nBufXSize / (downsample[1] + 1))
if (downsample[2] > 0)
nBufYSize = ceiling(nBufYSize / (downsample[2] + 1))
# issue #438:
if (any(downsample > 0) && !is.null(attr(x, "RasterIO")))
warning("with RasterIO defined, argument downsample is ignored")
rasterio = attr(x, "RasterIO") %||% list(nXOff = dx$from, nYOff = dy$from,
nXSize = nXSize, nYSize = nYSize, nBufXSize = nBufXSize, nBufYSize = nBufYSize)
# select bands?
bands <- d[["band"]]
if (!is.null(bands)) {
if (!is.null(bands$values) && is.numeric(bands$values))
rasterio$bands = bands$values
else if (!is.na(bands$from) && !is.na(bands$to)
# && (bands$to - bands$from + 1) < length(x[[1]])
)
rasterio$bands = seq(bands$from, bands$to)
if (!is.null(rasterio$bands) && length(rasterio$bands) > 1 &&
length(rasterio$bands) == length(x[[1]])) # one band in each file
rasterio$bands = NULL # https://github.com/r-spatial/stars/issues/608
}
# do it:
ret = vector("list", length(x))
res <- attr(x, "resolutions")
for (i in seq_along(ret)) {
if (!is.null(res) && any(res[1,] != res[i,])) {
mult = c(res[i,1] / res[1,1], res[i,2] / res[1,2])
rasterio$nXOff = floor((dx$from - 1) / mult[1]) + 1
rasterio$nYOff = floor((dy$from - 1) / mult[2]) + 1
rasterio$nXSize = ceiling(dx$to / mult[1]) - floor((dx$from - 1) / mult[1])
rasterio$nYSize = ceiling(dy$to / mult[2]) - floor((dy$from - 1) / mult[2])
rasterio$nBufXSize = ceiling(rasterio$nXSize * mult[1] / (downsample[1] + 1))
rasterio$nBufYSize = ceiling(rasterio$nXSize * mult[2] / (downsample[2] + 1))
mod = function(a, n) { a - n * floor(a/n) }
offset = round(c(mod(dx$from - 1, mult[1]), mod(dy$from - 1, mult[2])))
} else
offset = c(0,0)
file_name = unclass(x)[[i]]
if (is.function(file_name)) # realise/evaluate:
file_name = file_name()
ret[[i]] = read_stars(file_name, RasterIO = rasterio,
NA_value = attr(x, "NA_value") %||% NA_real_, normalize_path = FALSE,
proxy = FALSE, ...)
if (i == 1)
dm1 = dim(ret[[1]])
else {
xrange = seq_len(dm1[1]) + offset[1]
yrange = seq_len(dm1[2]) + offset[2]
ret[[i]] = ret[[i]] [ , xrange, yrange ]
st_dimensions(ret[[i]]) = st_dimensions(ret[[1]])
}
}
along = if (length(dim(x)) > 3)
setNames(list(st_get_dimension_values(x, 4)), tail(names(st_dimensions(x)), 1))
else
list(new_dim = names(x))
ret = if (length(ret) == 1)
st_redimension(ret[[1]], name = along)
else
do.call(c, lapply(ret, st_redimension, along = along))
new_dim = st_dimensions(ret)
# for (dm in setdiff(names(d), xy)) # copy over non x/y dimension values, if present:
# if (dm %in% names(new_dim))
# new_dim[[dm]] = d[[dm]]
if (length(d) > 2)
for (dm in 3:length(d)) {
new_dim[[dm]] = d[[dm]] # copy all fields - what if this was downsampled?
names(new_dim)[dm] = names(d)[dm]
}
ret = unclass(ret)
for (i in seq_along(ret)) {
file_dim = attr(x, "file_dim")
if (is.null(bands) && !is.null(file_dim) && ncol(file_dim) == length(dim(new_dim))
&& ncol(file_dim) == 3) { # https://github.com/r-spatial/stars/issues/596
r = new_dim[[3]]$from:new_dim[[3]]$to # FIXME: or else use $values?
ret[[i]] = ret[[i]][,,r]
}
dim(ret[[i]]) = dim(new_dim)
}
adrop(st_set_crs(st_stars(setNames(ret, names(x)), new_dim), st_crs(x)))
}
check_xy_warn = function(call, dimensions) {
if (as.character(as.list(call)[[1]]) == "st_apply") {
# check dims
MARGIN = as.list(call)$MARGIN
if (inherits(MARGIN, "call"))
MARGIN = eval(MARGIN, environment(call))
if (inherits(MARGIN, "name"))
MARGIN = get("MARGIN", environment(call))
xy = attr(dimensions, "raster")$dimensions
ok = if (is.numeric(MARGIN))
all(which(names(dimensions) %in% xy) %in% MARGIN)
else
all(xy %in% MARGIN)
if (!ok)
warning("st_apply on x/y dimensions applied to downsampled image(s)")
}
}
#' @name st_as_stars
#' @param downsample integer: if larger than 0, downsample with this rate (number of pixels to skip in every row/column); if length 2, specifies downsampling rate in x and y.
#' @param url character; URL of the stars endpoint where the data reside
#' @param envir environment to resolve objects in
#' @export
st_as_stars.stars_proxy = function(.x, ..., downsample = 0, url = attr(.x, "url"),
envir = parent.frame()) {
if (! is.null(url)) { # execute/get remotely: # nocov start
# if existing, convert call_list to character:
attr(.x, "call_list") = lapply(attr(.x, "call_list"), deparse)
# push the object to url, then st_as_stars() it there:
tempnam = substr(tempfile(pattern = "Z", tmpdir = "", fileext = ""), 2, 15)
put_data_url(url, tempnam, .x)
expr = paste0("st_as_stars(", tempnam, ", url = NULL, downsample=", downsample,
", envir = data)") # evaluate in "data" first
ret = get_data_url(url, expr)
put_data_url(url, tempnam, NULL) # remove the temporary object
ret # nocov end
} else {
cl = attr(.x, "call_list")
# FIXME: this means we ALWAYS process after (possibly partial) reading;
# there are cases where this is not right. Hence:
# TODO: only warn when there is a reason to warn.
if (!all(downsample == 0))
lapply(attr(.x, "call_list"), check_xy_warn, dimensions = st_dimensions(.x))
process_call_list(fetch(.x, ..., downsample = downsample), cl, envir = envir, downsample = downsample)
}
}
st_as_stars_proxy = function(x, fname = tempfile(fileext = rep_len(".tif", length(x))),
quiet = TRUE, NA_value = NA_real_) {
stopifnot(inherits(x, "stars"))
if (inherits(x, "stars_proxy"))
return(x)
for (i in seq_along(x))
write_stars(x[i], fname[i], NA_value = NA_value)
if (!quiet)
cat(paste("writing to", fname, "\n"))
st_stars_proxy(setNames(as.list(fname), names(x)), st_dimensions(x),
NA_value = NA_value, resolutions = NULL)
}
# execute the call list on a stars object
process_call_list = function(x, cl, envir = new.env(), downsample = 0) {
for (i in seq_along(cl)) {
if (is.character(cl[[i]]))
cl[[i]] = parse(text = cl[[i]])[[1]]
stopifnot(is.call(cl[[i]]))
env = environment(cl[[i]])
env [[ names(cl[[i]])[2] ]] = x # here, a stars_proxy may be replaced with the fetched stars object
old_downsample = env$downsample # might be NULL
if (!is.null(env$downsample) && any(env$downsample != downsample)) {
cat(paste0("overriding downsample of (sub)expression to c(", paste(downsample, collapse = ","), ")\n"))
env$downsample = downsample
}
# so we need to do that for other args too: https://github.com/r-spatial/stars/issues/390 :
if ("e2" %in% names(env) && inherits(env$e2, "stars_proxy")) # binary ops: also fetch the second arg
env$e2 = st_as_stars(env$e2, downsample = downsample)
x = eval(cl[[i]], env, parent.frame())
env$downsample = old_downsample
}
x
}
# add a call to the call list, possibly replacing function name (fn) and first arg name
collect = function(x, call, fn, args = "x", env, ...) {
call_list = attr(x, "call_list") %||% list()
dots = list(...)
nd = names(dots)
# I would say now to do
# env = as.environment(append(as.list(env), dots)) -> but that didn't work.
# so we iterate over ... :
for (i in seq_along(dots))
env[[ nd[i] ]] = dots[[i]]
args = c(args, nd)
# set function to call:
lst = as.list(call)
if (!missing(fn))
lst[[1]] = as.name(fn)
# set argument names:
if (!missing(fn) && fn == "[") {
lst[[2]] = as.name(args[1])
lst[[3]] = as.name(args[2])
for (i in seq_along(args)[-(1:2)]) {
if (!args[i] %in% names(lst))
lst[[ args[i] ]] = as.name(args[i]) # appends
}
} else {
for (i in seq_along(args)) {
lst[[i+1]] = as.name(args[i])
names(lst)[[i+1]] = args[i]
}
}
call = as.call(lst)
environment(call) = env
structure(x, call_list = c(call_list, call))
}
#' @export
adrop.stars_proxy = function(x, drop = which(dim(x) == 1), ...) {
collect(x, match.call(), "adrop", c("x", "drop"), env = environment(), ...)
}
#' @export
aperm.stars_proxy = function(a, perm = NULL, ...) {
collect(a, match.call(), "aperm", c("a", "perm"), env = environment(), ...)
}
#' @export
is.na.stars_proxy = function(x) {
collect(x, match.call(), "is.na", "x", env = environment())
}
#' @name stars_subset
#' @export
"[<-.stars_proxy" = function(x, i, downsample = 0, value) {
# https://stackoverflow.com/questions/9965577/copy-move-one-environment-to-another
# copy the environment, to avoid side effect later on:
# FIXME: to investigate - should this be done to env in every call to collect()?
env = as.environment(as.list(environment(), all.names = TRUE)) # copies
parent.env(env) = parent.env(environment())
collect(x, match.call(), "[<-", c("x", "i", "value", "downsample"), env)
}
#' @export
split.stars_proxy = function(x, ...) {
collect(x, match.call(), "split", env = environment())
}
#' @export
merge.stars_proxy = function(x, y, ..., name = "attributes") {
if (!missing(y))
stop("argument y needs to be missing: merging attributes of x")
if (!is.null(attr(x, "call_list")) || !is.null(attr(x, "resolutions"))) # postpone:
collect(x, match.call(), "merge", c("x", "y", "name"), env = environment(), ...)
else {
if (length(x) > 1) {
cl = class(x)
x = unclass(x)
x[[1]] = unlist(x)
x[2:length(x)] = NULL
class(x) = cl
}
st_stars_proxy(x, dimensions = create_dimensions(append(st_dimensions(x),
list(band = create_dimension(values = names(x[[1]])))),
raster = attr(st_dimensions(x), "raster")),
NA_value = attr(x, "NA_value"),
resolutions = attr(x, "resolutions"))
}
}
#' @export
"[.stars_proxy" = function(x, i = TRUE, ..., drop = FALSE, crop = TRUE) {
get_range = function(expr) {
v = try(eval(expr, parent.frame(2)), silent = TRUE)
if (is.numeric(v) && all(diff(v) == 1))
range(v)
else
NULL
}
rio = attr(x, "RasterIO")
dim_orig = dim(x)
mc = match.call()
lst = as.list(mc)
cl = attr(x, "call_list")
if (length(lst) < 3)
return(x) #
if (missing(i) | !"i" %in% names(lst)) # insert:
lst = c(lst[1:2], i = TRUE, lst[-(1:2)])
if (inherits(i, c("character", "logical", "numeric")) && is.null(cl)) {
if (!is.null(unclass(x)[[i]])) { # can/should be selected now:
if (!is.null(resolutions <- attr(x, "resolutions")))
resolutions = resolutions[i, ]
x = st_stars_proxy(unclass(x)[i], st_dimensions(x), NA_value = attr(x, "NA_value"),
resolutions = resolutions, file_dim = attr(x, "file_dim"),
RasterIO = rio)
lst[["i"]] = TRUE # this one has been handled now
}
ix = 1
while (length(lst) >= 4) { # https://github.com/r-spatial/stars/issues/496
if (!is.null(r <- get_range(lst[[4]]))) {
attr(x, "dimensions")[[ix]]$from = r[1]
attr(x, "dimensions")[[ix]]$to = r[2]
if(!is.null(attr(x, "dimensions")[[ix]]$values)) {
attr(x, "dimensions")[[ix]]$values <-
attr(x, "dimensions")[[ix]]$values[r[1]:r[2]]
}
}
ix = ix + 1
lst[[4]] = NULL # eat/remove
}
} else if (crop && inherits(i, c("sf", "sfc", "stars", "bbox"))) {
x = st_crop(x, i, ..., collect = FALSE) # does bounding box cropping only
if (inherits(i, c("stars", "bbox")))
lst[["i"]] = TRUE # this one has been handled now
}
# return or collect?
file_dim = attr(x, "file_dim") %||% matrix(dim(x)[1:2], 1)
n_file_dim = ncol(file_dim)
if (length(lst) == 3 && isTRUE(lst[["i"]]) && is.null(cl) && # drop a number of files in the lists of files?
length(x) && length(dim(x)) > n_file_dim &&
length(x[[1]]) == prod(dim_orig[-(seq_len(ncol(file_dim)))])) { # https://github.com/r-spatial/stars/issues/561
# select from the vectors of proxy object names:
get_ix = function(d) {
stopifnot(inherits(d, "dimension"))
if (!is.na(d$from))
seq(d$from, d$to)
else
d$values
}
d = st_dimensions(x)[-seq_len(n_file_dim)] # dimensions not in the file(s)
e = do.call(expand.grid, lapply(dim_orig[-seq_len(n_file_dim)], seq_len)) # all combinations
e$rn = seq_len(nrow(e)) # their index
f = do.call(expand.grid, lapply(d, get_ix)) # the ones we want
if (!requireNamespace("dplyr", quietly = TRUE))
stop("package dplyr required, please install it first") # nocov
sel = dplyr::inner_join(e, f, by = colnames(f))$rn
for (i in seq_along(x)) # select:
x[[i]] = x[[i]][sel]
x
} else { # still processing the geometries inside the bbox:
if (length(lst) == 3 && isTRUE(lst[["i"]]) && is.null(cl))
x
else
collect(x, as.call(lst), "[", c("x", "i", "drop", "crop"),
env = environment()) # postpone every arguments > 3 to after reading cells
}
}
# shrink bbox with e * width in each direction
bb_shrink = function(bb, e) {
dx = diff(bb[c("xmin", "xmax")])
dy = diff(bb[c("ymin", "ymax")])
st_bbox(setNames(c(bb["xmin"] + e * dx,
bb["ymin"] + e * dy,
bb["xmax"] - e * dx,
bb["ymax"] - e * dy), c("xmin", "ymin", "xmax", "ymax")))
}
#' @name st_crop
#' @param collect logical; if \code{TRUE}, repeat cropping on \code{stars} object, i.e. after data has been read
#' @export
st_crop.stars_proxy = function(x, y, ..., crop = TRUE, epsilon = sqrt(.Machine$double.eps), collect = TRUE) {
dm = st_dimensions(x)
d_max = dim(x) + sapply(dm, function(x) x$from) - 1
if (st_crs(x) != st_crs(y))
stop("for cropping, the CRS of both objects has to be identical")
if (crop && has_raster(x)) {
rast = attr(dm, "raster")$dimensions
xd = rast[1]
yd = rast[2]
bb = if (!inherits(y, "bbox"))
st_bbox(y)
else
y
if (epsilon != 0)
bb = bb_shrink(bb, epsilon)
# FIXME: document how EXACTLY cropping works; https://github.com/hypertidy/tidync/issues/73
cr = colrow_from_xy(matrix(bb, 2, byrow=TRUE), dm)
# crop x:
dm[[ xd ]]$from = max(1, cr[1, 1], na.rm = TRUE)
dm[[ xd ]]$to = min(d_max[xd], cr[2, 1], na.rm = TRUE)
if(!is.null(dm[[ xd ]]$values))
dm[[ xd ]]$values = dm[[ xd ]]$values[dm[[ xd ]]$from:dm[[ xd ]]$to]
# crop y:
if (!is.na(dm[[ yd ]]$delta) && dm[[ yd ]]$delta < 0) # FIXME: just subtract values to avoid NA miss?
cr[1:2, 2] = cr[2:1, 2]
dm[[ yd ]]$from = max(1, cr[1, 2], na.rm = TRUE)
dm[[ yd ]]$to = min(d_max[yd], cr[2, 2], na.rm = TRUE)
if(!is.null(dm[[ yd ]]$values))
dm[[ yd ]]$values = dm[[ yd ]]$values[dm[[ yd ]]$from:dm[[ yd ]]$to]
}
x = st_stars_proxy(x, dm, NA_value = attr(x, "NA_value"), resolutions = attr(x, "resolutions"),
file_dim = attr(x, "file_dim")) # crop to bb
if (collect)
collect(x, match.call(), "st_crop", c("x", "y", "crop", "epsilon"),
env = environment(), ...) # crops further when realised
else
x
}
#' @export
st_apply.stars_proxy = function(X, MARGIN, FUN, ..., CLUSTER = NULL, PROGRESS = FALSE,
FUTURE = FALSE, rename = TRUE, .fname) {
mc = match.call()
if (missing(.fname))
.fname = as.character(mc[["FUN"]])[1]
collect(X, mc, "st_apply", c("X", "MARGIN", "FUN", "CLUSTER", "PROGRESS", "FUTURE",
"rename", ".fname"), env = environment(), ...)
}
#' @export
#' @name predict.stars
predict.stars_proxy = function(object, model, ...) {
collect(object, match.call(), "predict", c("object", "model"), env = environment(), ...)
}
#' @export
"[[<-.stars_proxy" = function(x, i, value) {
y = unclass(x)
y[[i]] = value
structure(y, class = class(x))
}
#' @export
st_normalize.stars_proxy = function(x, domain = c(0, 0, 1, 1), ...) {
stopifnot(all(domain == c(0,0,1,1)))
d = st_dimensions(x)
stopifnot(d[[1]]$from == 1, d[[2]]$from == 1)
x
}
#' @export
image.stars_proxy <- function(x, ..., downsample = get_downsample(dim(x))) {
image(st_as_stars(x, downsample = downsample), ...)
}
#nocov start
get_data_url = function(url, expr = NULL) {
if (!requireNamespace("httr", quietly = TRUE)) # GET, POST, PUT
stop("package httr required, please install it first") # nocov
if (!requireNamespace("jsonlite", quietly = TRUE)) # base64_dec, base64_enc, toJSON, fromJSON
stop("package jsonlite required, please install it first") # nocov
if (is.null(expr))
jsonlite::fromJSON( httr::content(httr::GET(url), "text", encoding = "UTF-8"))
else {
js = jsonlite::fromJSON(
httr::content(httr::POST(url, body = list(expr = expr), encode = "json"),
"text", encoding = "UTF-8"))
if (is.list(js) && !is.null(js$error))
stop(paste(js$error, ":", js$message))
unserialize(jsonlite::base64_dec(js))
}
}
put_data_url = function(url, name, value) {
if (!requireNamespace("httr", quietly = TRUE)) # GET, POST, PUT
stop("package httr required, please install it first") # nocov
if (!requireNamespace("jsonlite", quietly = TRUE)) # base64_dec, base64_enc, toJSON, fromJSON
stop("package jsonlite required, please install it first") # nocov
value = jsonlite::toJSON(jsonlite::base64_enc(serialize(value, NULL)))
httr::PUT(url, body = list(name = name, value = value), encode = "json")
}
#nocov end
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.