sftime/ 0000755 0001762 0000144 00000000000 15177643560 011557 5 ustar ligges users sftime/MD5 0000644 0001762 0000144 00000003236 15177643560 012073 0 ustar ligges users 597bd9557f16177027e055f96613b6d2 *DESCRIPTION 19b1c3004325618d1056a33d23d3e036 *NAMESPACE d310e0179a67f9f3a1ef1f1ebd8c9ded *NEWS.md b280627ee10ea6c691bb4aaa2ffd77f2 *R/bind.R 6dfd1450c9352dc97fe8f49ea1493c61 *R/crop.R 25b20df90a96179bca3f806b9af97fb4 *R/geom-transformers.R 99c5a93686575b5a9b3c6f9cb34844b4 *R/init.R f84a8aa8cb4d3a94cbdc14b36d0cbf09 *R/join.R 46b6f4a5f9fa063460f91ab2809ede3f *R/plot.R 0e36dd2899f5be244a9567be15ef8167 *R/sftime.R 379a07b2b3de10a277bc87aa33ae4491 *R/st_cast.R 4c9acf1fe7556d4d8881496295ed35a5 *R/st_geometry.R 15a4e0ca6ab47f66b2190bf50bd61734 *R/st_time.R f6be28f92c02a679e64648596edc34d6 *R/tidyverse.R 011f2bd60caed056a90779f84a038f37 *build/vignette.rds 9ed3038050537738e1e5c8a6ae890f36 *inst/doc/sftime.R 25a9060e0b34a78b5cf055da6bce33d5 *inst/doc/sftime.Rmd bfc9aa56ad132ca7f55aaae63e1b7f6d *inst/doc/sftime.html d3a7b999282eb6c27f0ac237096931b0 *man/bind.Rd 4d71d1e9e969f7107bdbc868732b65f0 *man/geos_binary_ops.Rd 4df88399afb67be8c01378b4eb29c6e9 *man/geos_combine.Rd 581e32b3b47b09c48a7fb4bdf18fe189 *man/is_sortable.Rd 515ffee52acc35b73566496b75ca10f4 *man/plot.sftime.Rd b48c77fb32e5aeb031586161ee519502 *man/print.sftime.Rd 97cd42d2d082fcd2fbfbde0b23c6c6af *man/st_as_sftime.Rd 94ee6e4d6e05620852a940ebadfdc612 *man/st_cast.Rd 221b70c311258ed336de9ca511fe12e0 *man/st_crop.sftime.Rd 2463cc2de6f85298a0a327df5d28c01f *man/st_geometry.Rd b4abc940ae8ac92d001b69099cf0694b *man/st_join.Rd 144cbfa11de198578816407cf0c87ffc *man/st_sftime.Rd ab10b43ef666424b07ec3ab6198af849 *man/st_time.Rd bb232f329559c692efb3681fec0ae582 *man/tidyverse.Rd 6191cc6b59e14b943b962849a3d1251e *man/transform.sftime.Rd 25a9060e0b34a78b5cf055da6bce33d5 *vignettes/sftime.Rmd sftime/R/ 0000755 0001762 0000144 00000000000 14474157033 011752 5 ustar ligges users sftime/R/plot.R 0000644 0001762 0000144 00000005167 14232675654 013072 0 ustar ligges users #' Plots an \code{sftime} object #' #' \code{plot.sftime} #' #' @aliases plot #' @param x The \code{\link[=st_sftime]{sftime}} object to be plotted. #' @param y A character value; The variable name to be plotted; if missing, the #' first variable is plotted. #' @param ... Additional arguments; Passed on to \code{\link[sf:plot]{plot.sf}}. #' @param number A numeric value; The number of panels to be plotted, cannot be #' larger than the number of timestamps; ignored when \code{tcuts} is provided. #' @param tcuts predefined temporal ranges assigned to each map; if missing, #' will be determined as equal spans according to \code{number}. #' #' @importFrom graphics plot #' #' @return Returns \code{NULL} and creates as side effect a plot for \code{x}. #' @examples #' set.seed(123) #' coords <- matrix(runif(100), ncol = 2) #' g <- st_sfc(lapply(1:50, function(i) st_point(coords[i, ]) )) #' sft <- st_sftime(a = 1:50, g, time = as.POSIXct("2020-09-01 00:00:00") + 0:49 * 3600 * 6) #' #' plot(sft) #' #' @export plot.sftime <- function(x, y, ..., number = 6, tcuts) { if (missing(y)) y <- colnames(x)[[1]] stopifnot(y %in% colnames(x)) ts <- st_time(x) if(any(is.na(ts))) { message("[INFO] there are ", sum(is.na(ts)), " `NA` values in the active time column of `x`. These rows are dropped.") } x <- x[!is.na(ts), ] ts <- st_time(x) if (missing(tcuts)) { ts_ord <- order(ts) ts_fac <- tryCatch(as.factor(ts[ts_ord]), error = function(e) e) if (inherits(ts_fac, "error")) { ts_fac <- factor( as.character(ts[ts_ord]), levels = unique(as.character(ts[ts_ord])), ordered = TRUE ) } ts_nlv <- length(levels(ts_fac)) if (number > ts_nlv) { number <- ts_nlv message("[INFO] Fewer time stamps in the data than asked for; argument 'number' set to: ", ts_nlv) } tcuts <- seq(1, ts_nlv, length.out = number + 1) timeclass <- findInterval(as.numeric(ts_fac), tcuts, rightmost.closed = TRUE) } else { number <- length(tcuts) - 1 timeclass <- findInterval(ts, tcuts, rightmost.closed = TRUE) } d_ord <- as.data.frame(x)[order(ts), y, drop = FALSE] data <- d_ord if (number > 1) { for (i in 2:number) { data <- cbind(data, d_ord[, 1]) data[timeclass != i, i] = NA if (i == number) data[timeclass != 1, 1] <- NA # deal with first time class } } names(data) <- ts_fac[!duplicated(timeclass)] d <- sf::st_sf(data, geometry = sf::st_geometry(x)) plot(d, ...) NULL } sftime/R/st_time.R 0000644 0001762 0000144 00000007600 14232675654 013552 0 ustar ligges users #' Get, set, or replace time information #' #' @param obj An object of class \code{sftime}. #' @param x An object of class \code{sftime} or \code{sf}. #' @param ... Additional arguments; Ignored. #' @param time_column_name Character value; The name of the column to set as #' active time column in \code{x}. #' @param value An object for which \code{\link{is_sortable}} returns #' \code{TRUE} or an object of class \code{character}, or \code{NULL}. #' #' @details In case \code{value} is character and \code{x} is of class #' \code{sftime}, the active time column (as indicated by attribute #' \code{time_column}) is set to \code{x[[value]]}. #' #' The replacement function applied to \code{sftime} objects will overwrite the #' active time column, if \code{value} is \code{NULL}, it will remove it and #' coerce \code{x} to an \code{sftime} object. #' #' @return \code{st_time} returns the content of the active time column of an #' \code{sftime} object. #' Assigning an object for which \code{\link{is_sortable}} returns \code{TRUE} #' to an \code{sf} object creates an \code{\link[=st_sftime]{sftime}} object. #' Assigning an object for which \code{\link{is_sortable}} returns \code{TRUE} #' to an \code{sftime} object replaces the active time column by this object. #' @export st_time <- function(obj, ...) UseMethod("st_time") #' @rdname st_time #' @export `st_time<-` = function(x, ..., value) UseMethod("st_time<-") #' @rdname st_time #' @export #' @examples #' # from sftime object #' g <- st_sfc(st_point(1:2)) #' time <- Sys.time() #' x <- st_sftime(a = 3, g, time = time) #' st_time(x) #' st_time.sftime <- function(obj, ...) { ret <- obj[[attr(obj, "time_column")]] if (!is_sortable(ret)) # corrupt! stop('attr(obj, "time_column") does not point to a time column.\nDid you rename it, without setting st_time(obj) <- "newname"?') ret } #' @rdname st_time #' @export #' @examples #' ## assign a vector with time information #' #' # to sf object #' x <- st_sf(a = 3, g) #' st_time(x) <- time #' x #' `st_time<-.sf` <- function(x, ..., time_column_name = "time", value) { stopifnot(is_sortable(value)) stopifnot(is.character(time_column_name) && length(time_column_name) == 1) x[[time_column_name]] <- value st_sftime(x, time_column_name = time_column_name) } #' @rdname st_time #' @export #' @examples #' # to sftime object #' x <- st_sftime(a = 3, g, time = time) #' st_time(x) <- Sys.time() #' #' ## change the time column to another already existing column #' st_time(x) <- "a" #' #' ## remove time column from sftime object #' st_time(x) <- NULL #' `st_time<-.sftime` = function(x, ..., value) { if (! is.null(value)) { stopifnot(is_sortable(value) || is.character(value)) } if (! is.null(value) && is.character(value) && length(value) == 1 && value %in% colnames(x)) {# set flag to another column attr(x, "time_column") <- value } else {# replace, remove, or set list-column x[[attr(x, "time_column")]] <- value } if (is.null(value)) structure(x, time_column = NULL, class = setdiff(class(x), "sftime")) else st_as_sftime(x) } #' @rdname st_time #' @export #' @examples #' ## pipe-friendly #' #' # assign time column to sf object #' x <- st_sf(a = 3, g) #' x <- st_set_time(x, time) #' #' # remove time column from sftime object #' st_set_time(x, NULL) #' st_set_time <- function(x, value, ...) { st_time(x, ...) <- value x } #' @rdname st_time #' @export #' @details \code{st_drop_time} drops the time column of its argument, and #' reclasses it accordingly. #' @examples #' ## drop time column and class #' #' # same as x <- st_set_time(x, NULL) #' st_drop_time(x) #' st_drop_time = function(x) { if (!inherits(x, "sftime")) stop("`st_drop_time` only works with objects of class sftime") st_set_time(x, NULL) } sftime/R/tidyverse.R 0000644 0001762 0000144 00000023067 15175611736 014127 0 ustar ligges users # Tidyverse methods (See also join.R) #' 'tidyverse' methods for \code{sftime} objects #' #' 'tidyverse' methods for \code{sftime} objects. Geometries are sticky, use #' \code{\link{as.data.frame}} to let \code{dplyr}'s own methods drop them. Use #' these methods without the \code{.sftime} suffix and after loading the #' 'tidyverse' package with the generic (or after loading package 'tidyverse'). #' @name tidyverse #' @inheritParams sf::tidyverse #' @inheritParams tidyr::pivot_longer #' @param x An object of class \code{sftime}. #' @param y See \code{dplyr::`mutate-joins`}. #' @param .data An object of class \code{stime}. #' @return #' \itemize{ #' \item For \code{_join} methods: An object of class \code{sftime} #' representing the joining result of \code{x} and \code{y}. See #' \code{\link[dplyr]{mutate-joins}}. #' \item For \code{filter}: See \code{\link[dplyr]{filter}}. #' \item For \code{arrange}: See \code{\link[dplyr]{arrange}}. #' \item For \code{group_by} and \code{ungroup}: A grouped \code{sftime} #' object. See \code{\link[dplyr]{arrange}}. #' \item For \code{rowwise}: An \code{sftime} object. See #' \code{\link[dplyr]{rowwise}}. #' \item For \code{mutate} and \code{transmute}: See #' \code{\link[dplyr]{mutate}}. #' \item For \code{select}: See \code{\link[dplyr]{select}}. If the active #' time column is not explicitly selected, a \code{sf} object is returned. #' \item For \code{rename}: See \code{\link[dplyr]{rename}}. #' \item For \code{slice}: See \code{\link[dplyr]{slice}}. #' \item For \code{summarize} and \code{summarise}: See #' \code{\link[dplyr]{summarise}}. #' \item For \code{distinct}: See \code{\link[dplyr]{distinct}}. #' \item For \code{gather}: See \code{\link[tidyr]{gather}}. #' } #' NULL #' @rdname tidyverse #' @examples #' ## filter #' filter(x1, a <= 2) #' filter.sftime <- function(.data, ..., .dots) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## arrange #' arrange(x1, dplyr::desc(a)) #' arrange.sftime <- function(.data, ..., .dots) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## group_by #' group_by(x1, time) #' group_by.sftime <- function(.data, ..., add = FALSE) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## ungroup #' ungroup(group_by(x1, time)) #' ungroup.sftime <- function(.data, ...) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## rowwise #' x1 |> #' mutate(a1 = 5:7) |> #' rowwise() |> #' mutate(a2 = mean(a, a1)) #' rowwise.sftime <- function(.data, ...) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## mutate #' x1 |> #' mutate(a1 = 5:7) #' mutate.sftime <- function(.data, ..., .dots) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## transmute #' x1 |> #' transmute(a1 = 5:7) #' transmute.sftime <- function(.data, ..., .dots) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## select #' x1 |> #' select(-time) |> #' select(geometry) #' select.sftime <- function(.data, ...) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## rename #' x1 |> #' rename(a1 = a) #' rename.sftime <- function(.data, ...) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## slice #' x1 |> #' slice(1:2) #' slice.sftime <- function(.data, ..., .dots) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## summarise #' x1 |> #' summarise(time = mean(time)) #' #' x1 |> #' summarize(time = mean(time)) #' summarise.sftime <- function(.data, ..., .dots, do_union = TRUE, is_coverage = FALSE) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse summarize.sftime <- summarise.sftime #' @rdname tidyverse #' @examples #' ## distinct #' x1 |> #' distinct(geometry) #' distinct.sftime <- function(.data, ..., .keep_all = FALSE) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @rdname tidyverse #' @examples #' ## gather #' library(tidyr) #' x1 |> #' mutate(a1 = 5:7) |> #' gather(key = "variable", value = "value", a, a1) #' gather.sftime <- function(data, key, value, ..., na.rm = FALSE, convert = FALSE, factor_key = FALSE) { reclass_sftime(NextMethod(), time_column_name = attr(data, "time_column")) } #' @rdname tidyverse #' @examples #' ## pivot_longer #' x1 |> #' mutate(a1 = 5:7) |> #' pivot_longer(cols = c("a", "a1"), names_to = "variable", values_to = "value") #' pivot_longer.sftime <- function (data, cols, names_to = "name", names_prefix = NULL, names_sep = NULL, names_pattern = NULL, names_ptypes = NULL, names_transform = NULL, names_repair = "check_unique", values_to = "value", values_drop_na = FALSE, values_ptypes = NULL, values_transform = NULL, ...) { reclass_sftime(NextMethod(), time_column_name = attr(data, "time_column")) } #' @rdname tidyverse #' @examples #' ## spread #' x1 |> #' mutate(a1 = 5:7) |> #' gather(key = "variable", value = "value", a, a1) |> #' spread(key = "variable", value = "value") #' spread.sftime <- function(data, key, value, fill = NA, convert = FALSE, drop = TRUE, sep = NULL) { reclass_sftime(NextMethod(), time_column_name = attr(data, "time_column")) } #' @rdname tidyverse #' @examples #' ## sample_n #' set.seed(234) #' x1 |> #' sample_n(size = 10, replace = TRUE) #' sample_n.sftime <- function(tbl, size, replace = FALSE, weight = NULL, .env = parent.frame()) { reclass_sftime(NextMethod(), time_column_name = attr(tbl, "time_column")) } #' @rdname tidyverse #' @examples #' ## sample_frac #' x1 |> #' sample_frac(size = 10, replace = TRUE) |> #' sample_frac(size = 0.1, replace = FALSE) #' sample_frac.sftime <- function(tbl, size = 1, replace = FALSE, weight = NULL, .env = parent.frame()) { reclass_sftime(NextMethod(), time_column_name = attr(tbl, "time_column")) } #' @rdname tidyverse #' @examples #' ## nest #' x1 |> #' nest(a1 = -time) #' nest.sftime <- function (.data, ...) { reclass_sftime(NextMethod(), time_column_name = attr(.data, "time_column")) } #' @name tidyverse #' @examples #' ## unnest #' x1 |> #' mutate(a1 = list(1, c(1, 2), 5)) |> #' unnest(a1) #' unnest.sftime = function(data, ..., .preserve = NULL) { reclass_sftime(NextMethod(), time_column_name = attr(data, "time_column")) } #' @rdname tidyverse #' @examples #' ## separate #' x1 |> #' mutate(x = c(NA, "a.b", "a.d")) |> #' separate(x, c("A", "B")) #' separate.sftime <- function(data, col, into, sep = "[^[:alnum:]]+", remove = TRUE, convert = FALSE, extra = "warn", fill = "warn", ...) { time_column_name <- attr(data, "time_column") class(data) <- setdiff(class(data), "sftime") # modified from sftime (tidyverse.R) if (!requireNamespace("rlang", quietly = TRUE)) stop("rlang required: install first?") col <- rlang::enquo(col) res <- tidyr::separate(data, !!col, into = into, sep = sep, remove = remove, convert = convert, extra = extra, fill = fill, ...) reclass_sftime(res, time_column_name = time_column_name) } #' @name tidyverse #' @examples #' ## unite #' x1 |> #' mutate(x = c(NA, "a.b", "a.d")) |> #' separate(x, c("A", "B")) |> #' unite(x, c("A", "B")) #' unite.sftime <- function(data, col, ..., sep = "_", remove = TRUE) { reclass_sftime(NextMethod(), time_column_name = attr(data, "time_column")) } #' @rdname tidyverse #' @examples #' ## separate_rows #' x1 |> #' mutate(z = c("1", "2,3,4", "5,6")) |> #' separate_rows(z, convert = TRUE) #' separate_rows.sftime <- function(data, ..., sep = "[^[:alnum:]]+", convert = FALSE) { reclass_sftime(NextMethod(), time_column_name = attr(data, "time_column")) } # modified from https://github.com/r-spatial/sf/blob/9d3bcf864f77f651281e23cde6747d440fb54242/R/tidyverse.R: # This is currently only used in `bind_rows()` and `bind_cols()` # because sf overrides all default implementations dplyr_reconstruct.sftime <- function(data, template) { data <- NextMethod() time_column_name <- attr(template, "time_column") # if the sf object could not be reconstructed or there is no time column, return `data` as is if (! inherits(data, "sf") || ! time_column_name %in% names(data)) { data } else { st_as_sftime( data, time_column_name = time_column_name ) } } #' @rdname tidyverse #' @examples #' ## drop_na #' x1 |> #' mutate(z = c(1, 2, NA)) |> #' drop_na(z) #' #' x1 |> #' mutate(z = c(1, NA, NA)) |> #' drop_na(z) #' #' x1 |> #' mutate(time = replace(time, 1, NA)) |> #' drop_na(time) drop_na.sftime <- function(data, ...) { reclass_sftime(NextMethod(), time_column_name = attr(data, "time_column")) } sftime/R/st_cast.R 0000644 0001762 0000144 00000001210 15175611736 013533 0 ustar ligges users #' Cast geometry to another type: either simplify, or cast explicitly #' #' @name st_cast #' @inheritParams sf::st_cast #' @param x An object of class \code{sftime}. #' @return \code{x} with changed geometry type. #' @examples #' # cast from POINT to LINESTRING #' g <- st_sfc(st_point(1:2), st_point(c(2, 4))) #' time <- Sys.time() #' x <- #' st_sftime(a = 3:4, g, time = time) |> #' dplyr::group_by(time) |> #' dplyr::summarize(do_union = TRUE) |> #' st_cast(to = "LINESTRING") #' @export st_cast.sftime <- function(x, to, ..., warn = TRUE, do_split = TRUE) { reclass_sftime(NextMethod(), attr(x, "time_column")) } sftime/R/geom-transformers.R 0000644 0001762 0000144 00000011001 14232675654 015546 0 ustar ligges users #' Geometric operations on pairs of simple feature geometry sets (including \code{sftime} objects) #' #' @name geos_binary_ops #' @param x object of class \code{sftime}, \code{sf}, \code{sfc} or \code{sfg}. #' @param y object of class \code{sftime}, \code{sf}, \code{sfc} or \code{sfg}. #' @param ... See \code{\link[sf:geos_binary_ops]{geos_binary_ops}}. #' @return The intersection, difference or symmetric difference between two sets #' of geometries. #' The returned object has the same class as that of the first argument #' (\code{x}) with the non-empty geometries resulting from applying the #' operation to all geometry pairs in \code{x} and \code{y}. In case \code{x} #' is of class \code{sf} or \code{sftime}, the matching attributes of the #' original object(s) are added. The \code{sfc} geometry list-column returned #' carries an attribute \code{idx}, which is an \code{n}-by-2 matrix with every #' row the index of the corresponding entries of \code{x} and \code{y}, #' respectively. #' #' @examples #' g <- st_sfc(st_point(c(1, 2)), st_point(c(1, 3)), st_point(c(2, 3)), #' st_point(c(2, 1)), st_point(c(3, 1))) #' tc <- Sys.time() + 1:5 #' x1 <- st_sftime(a = 1:5, g, time = tc) #' x2 <- st_buffer(x1, dist = 1) #' NULL #' Intersection #' @name geos_binary_ops #' @details \code{st_intersection}: When called with a missing \code{y}, the #' \code{sftime} method for \code{st_intersection} returns an \code{sftime} #' object with attributes taken from the contributing feature with lowest index; #' two fields are added: #' \describe{ #' \item{\code{n.overlaps}}{The number of overlapping features in \code{x}.} #' \item{\code{origins}}{A list-column with indexes of all overlapping #' features.} #' } #' #' @examples #' ## intersection #' #' # only x provided (no y) #' plot(st_intersection(x2)) #' #' # with arguments x and y provided #' plot(st_intersection(x2, x1)) #' #' @export st_intersection.sftime <- function(x, y, ...) { time_column_name <- attr(x, "time_column") reclass_sftime(NextMethod(), time_column_name = time_column_name) } #' Difference #' @name geos_binary_ops #' @details \code{st_difference}: When \code{st_difference} is called with a #' single argument, overlapping areas are erased from geometries that are #' indexed at greater numbers in the argument to \code{x}; geometries that are #' empty or contained fully inside geometries with higher priority are removed #' entirely. #' #' @examples #' ## difference #' #' # only x provided (no y) #' plot(st_difference(x2)) #' #' # with arguments x and y provided #' plot(st_difference(x2, x1)) #' #' @export st_difference.sftime <- function(x, y, ...) { time_column_name <- attr(x, "time_column") reclass_sftime(NextMethod(), time_column_name = time_column_name) } #' @name geos_binary_ops #' @examples #' ## symmetric difference #' plot(st_sym_difference(x1, x2)) #' #' @export st_sym_difference.sftime <- function(x, y, ...) { time_column_name <- attr(x, "time_column") reclass_sftime(NextMethod(), time_column_name = time_column_name) } #' Combine or union feature geometries (including \code{sftime} objects) #' #' @name geos_combine #' @param x An object of class \code{sftime}, \code{sf}, \code{sfc} or #' \code{sfg}. #' @param y An object of class \code{sftime}, \code{sf}, \code{sfc} or #' \code{sfg} (optional). #' @param by_feature See \code{\link[sf:geos_combine]{geos_combine}}. #' @param is_coverage See \code{\link[sf:geos_combine]{geos_combine}}. #' @param ... See \code{\link[sf:geos_combine]{geos_combine}}. #' @return If \code{y} is missing, \code{st_union(x)} returns a single geometry #' with resolved boundaries, else the geometries for all unioned pairs of #' \code{x[i]} and \code{y[j]}. #' @details #' See \code{\link[sf:geos_combine]{geos_combine}}. #' #' @examples #' # union simple features in an sftime object #' g <- st_sfc(st_point(c(1, 2)), st_point(c(1, 3)), st_point(c(2, 3)), #' st_point(c(2, 1)), st_point(c(3, 1))) #' tc <- Sys.time() + 1:5 #' x <- st_sftime(a = 1:5, g, time = tc) #' #' # only x provided (no y) #' plot(st_union(st_buffer(x, dist = 1))) #' #' # with arguments x and y provided #' plot(st_union(st_buffer(x, dist = 1), st_buffer(x, dist = 0.5)), "a") #' #' @export st_union.sftime <- function(x, y, ..., by_feature = FALSE, is_coverage = FALSE) { time_column_name <- attr(x, "time_column") reclass_sftime(NextMethod(), time_column_name = time_column_name) } sftime/R/st_geometry.R 0000644 0001762 0000144 00000001347 14232675654 014451 0 ustar ligges users #' Drops the geometry column of \code{sftime} objects #' #' Drops the geometry column of an \code{sftime} object. This will also drop #' the \code{sftime} class attribute and \code{time_column} attribute. #' #' @name st_geometry #' @inheritParams sf::st_drop_geometry #' @param x An \code{sftime} object. #' @return \code{x} without geometry column and without \code{sftime} and #' \code{sf} class. #' @examples #' # dropping the geometry column will also drop the `sftime` class: #' g <- st_sfc(st_point(1:2)) #' time <- Sys.time() #' x <- st_sftime(a = 3, g, time = time) #' st_drop_geometry(x) #' #' @export st_drop_geometry.sftime <- function(x, ...) { class(x) <- setdiff(class(x), "sftime") NextMethod() } sftime/R/sftime.R 0000644 0001762 0000144 00000070267 15047042113 013365 0 ustar ligges users #### construction #### #' Checks whether a vector or list is sortable #' #' Checks whether a vector or list is sortable. This is the condition for a #' vector to be usable as time column in a \code{sftime} object. #' #' @name is_sortable #' @param x The object to check. #' @return \code{TRUE} if \code{x} passes the check, else \code{FALSE}. #' @keywords internal #' #' @details Checks whether the provided object can be handled by #' \code{\link{order}}. A couple of basic types are whitelisted. However, custom #' types can be defined when they provide a dedicated generic to \link{xtfrm}. #' Note that a \code{list} can only be sorted with \link{atomic} values. See the #' examples below for a template. #' #' @examples #' x <- Sys.time() + 5:1 * 3600 * 24 #' sort(x) #' is_sortable(x) #' #' @importFrom utils methods #' @export is_sortable <- function(x) { # can x be sorted? # sort.default checks 'is.object(x)' and uses 'order' to subset and sort the object # lists and vectors are no objects, sort then uses sort.int which can only handle atomic values # Examples: # x <- Sys.time() + 5:1 * 3600*24 # x <- yearmon(2020+c(5:0)/12) # x <- yearqtr(2020+c(5:0)/4) # x <- factor(LETTERS[sample(26, replace = T)], levels=LETTERS[sample(26)]) # sort(x) # order(x) # class(x) any(vapply(class(x), function(y) y %in% c("integer", "numeric", "POSIXct", "POSIXlt", "Date", "yearmon", "yearqtr", "factor"), TRUE)) || # have a list of wellknown exceptions any(vapply(class(x), function(y) paste("xtfrm", y, sep=".") %in% methods(class = y), TRUE)) # check for function 'xtfrm.[CLASSNAME]' which is used by 'order' which in turn is used by sort.default } #' Construct an \code{sftime} object from all its components #' #' @param ... Column elements to be binded into an \code{sftime} object or a #' single \code{list} or \code{data.frame} with such columns. At least one of #' these columns shall be a geometry list-column of class \code{sfc} and one #' shall be a time column (to be specified with \code{time_column_name}). #' @param crs Coordinate reference system, something suitable as input to #' \code{\link[sf]{st_crs}}. #' @param agr A character vector; see details below. #' @param row.names row.names for the created \code{sf} object. #' @param stringsAsFactors A logical value; see #' \code{\link[sf]{st_read}}. #' @param precision A numeric value; see #' \code{\link[sf]{st_as_binary}}. #' @param sf_column_name A character value; name of the active list-column with #' simple feature geometries; in case there is more than one and #' \code{sf_column_name} is \code{NULL}, the first one is taken. #' @param time_column_name A character value; name of the active #' time column. In case \code{time_column_name} is \code{NULL}, the first #' \code{\link{POSIXct}} column is taken. If there is no \code{POSIXct} column, #' the first \code{\link{Date}} column is taken. #' @param sfc_last A logical value; if \code{TRUE}, \code{sfc} columns are #' always put last, otherwise column order is left unmodified. #' @param time_column_last A logical value; if \code{TRUE}, the active time column is #' always put last, otherwise column order is left unmodified. If both \code{sfc_last} #' and \code{time_column_last} are \code{TRUE}, the active time column is put last. #' @param check_ring_dir A logical value; see \code{\link[sf]{st_read}}. #' #' @return \code{st_sftime}: An object of class \code{sftime}. #' @examples #' ## construction with an sfc object #' library(sf) #' g <- st_sfc(st_point(1:2)) #' tc <- Sys.time() #' st_sftime(a = 3, g, time = tc) #' #' ## construction with an sf object #' \dontrun{ #' st_sftime(st_sf(a = 3, g), time = tc) #' # error, because if ... contains a data.frame-like object, no other objects #' # may be passed through ... . Instead, add the time column before. #' } #' #' st_sftime(st_sf(a = 3, g, time = tc)) #' #' @export st_sftime <- function(..., agr = sf::NA_agr_, row.names, stringsAsFactors = TRUE, crs, precision, sf_column_name = NULL, time_column_name = NULL, check_ring_dir = FALSE, sfc_last = TRUE, time_column_last = TRUE) { # checks stopifnot(is.null(time_column_name) || (is.character(time_column_name) && length(time_column_name) == 1)) stopifnot(is.logical(time_column_last) && length(time_column_last) == 1) # pass to sf::st_sf to get sf object x <- list(...) res <- sf::st_sf(..., agr = agr, row.names = row.names, stringsAsFactors = stringsAsFactors, crs = crs, precision = precision, sf_column_name = sf_column_name, sfc_last = sfc_last) # get info on active time column (modified from sf) if(!is.null(time_column_name)) { # time column manually specified stopifnot(time_column_name %in% colnames(res)) stopifnot(is_sortable(res[[time_column_name]])) res_time_column <- match(time_column_name, colnames(res)) res_time_column_name <- time_column_name } else { #search for POSIXct and Date columns # search time column(s) all_time_column_names <- NULL all_time_columns <- vapply(res, function(x) inherits(x, "POSIXct"), TRUE) if(!any(all_time_columns)) { all_time_columns <- vapply(res, function(x) inherits(x, "Date"), TRUE) } if(!any(all_time_columns)) stop("No time column found.") all_time_columns <- which(unlist(all_time_columns)) res_time_column <- all_time_columns[[1L]] res_time_column_name <- names(all_time_columns)[[1L]] } # sort time column if(time_column_last) { res_only_time_column <- sf::st_drop_geometry(res[, res_time_column])[, 1, drop = TRUE] res <- res[, -res_time_column] res[, res_time_column_name] <- res_only_time_column res <- sf::st_sf(res, agr = agr, row.names = row.names, stringsAsFactors = stringsAsFactors, crs = crs, precision = precision, sf_column_name = sf_column_name, sfc_last = FALSE) } # add attributes attr(res, "time_column") <- res_time_column_name if(!inherits(res, "sftime")) class(res) <- c("sftime", class(res)) res } #' Helper function for reclassing \code{sftime} objects #' #' Reclasses \code{sftime} objects to the correct new class after modification. #' Checks if the \code{sftime} object (the active time column) gets invalidated. #' If so, the \code{sftime} class is dropped. If not, the object is reclassed to #' an \code{sftime} object. #' #' @param x An object to be reclassed to the \code{\link[=st_sftime]{sftime}} class. #' @param time_colmn_name A character value; name of the active time column. #' @return \code{x} as \code{sftime} object if the column indicated by #' \code{time_colmn_name} is a valid time column (\code{\link{is_sortable}}) and #' \code{x} without \code{time_column} attribute if not. #' #' @keywords internal #' @noRd reclass_sftime <- function(x, time_column_name) { if(! time_column_name %in% colnames(x) || ! inherits(x, "sf")) { structure(x, class = setdiff(class(x), "sftime"), time_column = NULL) } else { structure(x, class = c("sftime", setdiff(class(x), "sftime")), time_column = time_column_name) } } #### subsetting #### #' @name st_sftime #' @param x An object of class \code{sf}. #' @param i Record selection, see \link{[.data.frame} #' @param j Variable selection, see \link{[.data.frame} #' @param drop A logical value, default \code{FALSE}; if \code{TRUE} drop the #' geometry column and return a \code{data.frame}, else make the geometry sticky #' and return an \code{sf} object. #' @param op A function; geometrical binary predicate function to apply when #' \code{i} is a simple feature object. #' @details See also \link{[.data.frame}; for \code{[.sftime} \code{...} #' arguments are passed to \code{op}. #' @return Returned objects for subsetting functions: \code{[.sf} will return a #' \code{data.frame} or vector if the geometry column (of class \code{sfc}) is #' dropped (\code{drop=TRUE}), an \code{sfc} object if only the geometry column #' is selected, and otherwise return an \code{sftime} object. #' @examples #' ## Subsetting #' g <- st_sfc(st_point(c(1, 2)), st_point(c(1, 3)), st_point(c(2, 3)), #' st_point(c(2, 1)), st_point(c(3, 1))) #' tc <- Sys.time() + 1:5 #' x <- st_sftime(a = 1:5, g, time = tc) #' #' # rows #' x[1, ] #' class(x[1, ]) #' #' x[x$a < 3, ] #' class(x[x$a < 3, ]) #' #' # columns #' x[, 1] #' class(x[, 1]) # drops time column as for ordinary data.frame subsetting, #' # keeps geometry column of sf object #' #' x[, 3] #' class(x[, 3]) # keeps time column because it is explicitly selected, #' # keeps geometry column of sf object, returns an sftime object #' #' x[, 3, drop = TRUE] #' class(x[, 3, drop = TRUE]) # if the geometry column is dropped, not only the #' # sf class is dropped, but also the sftime class #' #' x["a"] #' class(x["a"]) # Time columns are not sticky: If a column is selected by a #' # character vector and this does not contain the active time column, the time #' # column is dropped. #' #' x[c("a", "time")] #' class(x[c("a", "time")]) # keeps the time column #' #' # with sf or sftime object #' pol = st_sfc(st_polygon(list(cbind(c(0,2,2,0,0),c(0,0,2,2,0))))) #' h = st_sf(r = 5, pol) #' #' x[h, ] #' class(x[h, ]) # returns sftime object #' #' h[x, ] #' class(h[x, ]) # returns sf object #' #' @export "[.sftime" <- function(x, i, j, ..., drop = FALSE, op = sf::st_intersects) { # retain info on time column time_column <- attr(x, "time_column") # perform subsetting for sf object if((!missing(j) && !drop && ((is.character(j) && any(j == time_column)) || (is.numeric(j) && any(colnames(x)[j] == time_column)))) || !missing(i) && !drop && ((is.character(i)) && any(i == time_column) || is.numeric(i) || is.logical(i))) { structure(NextMethod(), class = class(x), time_column = time_column) } else { x <- structure(x, class = setdiff(class(x), "sftime"), time_column = NULL) NextMethod() } # ---todo: what to do when i is an sftime object: match also time info } #' @name st_sftime #' @param value An object to insert into \code{x} or with which to rename #' columns of \code{x}. #' @examples #' ## Assigning values to columns #' #' # assigning new values to a non-time column #' x[["a"]] <- 5:1 #' class(x) #' #' # assigning allowed new values to the time column #' x[["time"]] <- Sys.time() + 1:5 #' class(x) #' #' # assigning new values to the time column which invalidate the time column #' x[["time"]] <- list(letters[1:2]) #' class(x) #' #' @export "[[<-.sftime" <- function(x, i, value) { time_column_name <- attr(x, "time_column") reclass_sftime(NextMethod(), time_column_name = time_column_name) } #' @name st_sftime #' @examples #' # assigning new values with `$` #' x$time <- Sys.time() + 1:5 #' class(x) #' #' @export "$<-.sftime" = function(x, i, value) { structure(NextMethod(), class = c("sftime", setdiff(class(x), "sftime"))) } ##' name st_sftime ##' examples ##' # renaming column names ##' names(x)[1] <- "b" ##' ##' export #"names<-.sftime" <- function(x, value) { # out <- NextMethod() # dplyr_reconstruct.sftime(out, x) #} # ---todo: raises an error #### printing #### #' Helper function to print time columns when printing an \code{sftime} object #' #' @noRd #' @keywords internal #' @param x A time column from a \code{\link[=st_sftime]{sftime}} object. #' @param n An integer value; The first \code{n} elements of \code{x} to print. #' @param print_number_features A logical value; whether the number of features #' shall be printed (\code{TRUE}) or not (\code{FALSE}). #' #' @return \code{x} (invisible). print_time_column <- function(x, n = 5L, print_number_features = FALSE) { stopifnot(is.logical(print_number_features) && length(print_number_features) == 1) stopifnot(is.integer(n) && length(n) == 1) ord <- order(x, na.last = NA) if(length(x) != 0) { x_min <- x[[ord[[1]]]] x_max <- x[[ord[[length(ord)]]]] } else { x_min <- x_max <- NA } x_class <- class(x) x_is_value <- length(x) == 1 cat(paste0("Time column with ", ifelse(!print_number_features, "", paste0(length(x), ifelse(x_is_value, " feature of ", " features, each of "))), ifelse(length(x_class) == 1, "class", "classes"), ": \'", paste0(x_class, collapse="\', \'"), "\'.\n", ifelse(x_is_value, paste0("Representing ", x_min, ".\n" ), paste0("Ranging from ", x_min, " to ", x_max, ".\n" )))) for(i in seq_len(min(n, length(x)))) { ret <- x[[i]] class(ret) <- setdiff(class(ret), "tc") message(ret) } invisible(x) } #' Prints an \code{sftime} object #' #' @param x An object of class \code{sftime}. #' @param ... Currently unused arguments, for compatibility. #' @param n Numeric value; maximum number of printed elements. #' #' @return \code{x} (invisible). #' @examples #' g <- st_sfc(st_point(c(1, 2)), st_point(c(1, 3)), st_point(c(2, 3)), #' st_point(c(2, 1)), st_point(c(3, 1))) #' tc <- Sys.time() + 1:5 #' x <- st_sftime(a = 1:5, g, time = tc) #' print(x) #' print(x[0, ]) #' #' @export print.sftime <- function(x, ..., n = getOption("sf_max_print", default = 10)) { geoms <- which(vapply(x, function(col) inherits(col, "sfc"), TRUE)) nf <- length(x) - length(geoms) - 1 app <- paste("and", nf, ifelse(nf == 1, "field", "fields")) if (any(!is.na(st_agr(x)))) { su = summary(st_agr(x)) summ = paste(paste(su, names(su)), collapse = ", ") app <- paste0(app, "\n", "Attribute-geometry relationship: ", summ) } if (length(geoms) > 1) app <- paste0(app, "\n", "Active geometry column: ", attr(x, "sf_column")) print(st_geometry(x), n = 0, what = "Spatiotemporal feature collection with", append = app) # temporal information print_time_column(x[, attr(x, "time_column"), drop = TRUE], n = 0L, print_number_features = FALSE) if(n > 0) { if (inherits(x, "tbl_df")) { x_print <- x class(x_print) <- setdiff(class(x_print), c("sftime", "sf")) print(x_print) } else { y <- x if(nrow(y) > n) { cat(paste("First", n, "features:\n")) y <- x[seq_len(n), , drop = FALSE] } print.data.frame(y, ...) } } invisible(x) } #### coercion #### #' Convert a foreign object to an \code{sftime} object #' #' @name st_as_sftime #' @param x An object to be converted into an object of class #' \code{\link[=st_sftime]{sftime}}. #' @param ... Further arguments passed to methods. #' #' @return \code{x} converted to an \code{sftime} object. #' #' @export #' @importFrom methods slotNames as st_as_sftime = function(x, ...) UseMethod("st_as_sftime") #' @name st_as_sftime #' @examples #' # modified from spacetime: #' library(sp) #' library(spacetime) #' #' sp <- cbind(x = c(0,0,1), y = c(0,1,1)) #' row.names(sp) <- paste("point", 1:nrow(sp), sep="") #' sp <- SpatialPoints(sp) #' time <- as.POSIXct("2010-08-05") + 3600 * (10:12) #' x <- STI(sp, time) #' #' st_as_sftime(x) #' #' @export st_as_sftime.ST <- function(x, ...) { has_data <- "data" %in% slotNames(x) if (!inherits(x, "STI")) { if (has_data) x <- as(x, "STIDF") else x <- as(x, "STI") } times <- as.POSIXct(attr(x@time, "index"), origin = "1970-01-01") if (has_data) st_sftime(x@data, st_as_sfc(x@sp), time = times) else st_sftime(st_as_sfc(x@sp), time = times) } #' @name st_as_sftime #' @examples #' # convert a Track object from package trajectories to an sftime object #' library(trajectories) #' x1_Track <- trajectories::rTrack(n = 100) #' x1_Track@data$speed <- sort(rnorm(length(x1_Track))) #' x1_sftime <- st_as_sftime(x1_Track) #' #' @export st_as_sftime.Track <- function(x, ...) { has_data <- "data" %in% slotNames(x) if (has_data) x <- as(x, "STIDF") else x <- as(x, "STI") st_as_sftime(x) } #' @name st_as_sftime #' @return \code{st_as_sftime.Tracks} furthermore adds a column #' \code{track_name} with the names of the \code{tracks} slot of the input #' \code{Tracks} object. #' #' @examples #' # convert a Tracks object from package trajectories to an sftime object #' x2_Tracks <- trajectories::rTracks(m = 6) #' x2_sftime <- st_as_sftime(x2_Tracks) #' #' @export st_as_sftime.Tracks <- function(x, ...) { track_name <- unlist(lapply(seq_along(x@tracks), function(i) rep(names(x@tracks)[[i]], x@tracksData$n[[i]]))) cbind(st_as_sftime(as(x, "STIDF")), track_name = track_name) } #' @name st_as_sftime #' @return \code{st_as_sftime.TracksCollection} furthermore adds the columns #' \code{tracks_name} with the names of the \code{tracksCollection} slot and #' \code{track_name} with the names of the \code{tracks} slot of the input #' \code{Tracks} object. #' #' @examples #' # convert a TracksCollection object from package trajectories to an sftime object #' x3_TracksCollection <- trajectories::rTracksCollection(p = 2, m = 3, n = 50) #' x3_sftime <- st_as_sftime(x3_TracksCollection) #' #' @export st_as_sftime.TracksCollection <- function(x, ...) { track_names <- do.call(rbind, lapply(seq_along(x@tracksCollection), function(i) { n <- sum(x@tracksCollection[[i]]@tracksData$n) track_i <- x@tracksCollection[[i]] data.frame( tracks_name = rep(names(x@tracksCollection)[[i]], n), track_name = unlist(lapply(seq_along(track_i@tracks), function(j) rep(names(track_i@tracks)[[j]], track_i@tracksData$n[[j]]))), stringsAsFactors = FALSE ) })) cbind(st_as_sftime(as(x, "STIDF")), track_names) } #' @name st_as_sftime #' @examples #' # convert an sftime object to an sftime object #' st_as_sftime(x3_sftime) #' #' @export st_as_sftime.sftime <- function(x, ...) x #' @name st_as_sftime #' @param time_column_name A character value; name of the active time column. In #' case there is more than one and \code{time_column_name} is \code{NULL}, the #' first one is taken. #' @examples #' # convert an sf object to an sftime object #' g <- st_sfc(st_point(c(1, 2)), st_point(c(1, 3)), st_point(c(2, 3)), #' st_point(c(2, 1)), st_point(c(3, 1))) #' x4_sf <- st_sf(a = 1:5, g, time = Sys.time() + 1:5) #' x4_sftime <- st_as_sftime(x4_sf) #' #' @export st_as_sftime.sf <- function(x, ..., time_column_name = NULL) { st_sftime(x, ..., time_column_name = time_column_name) } #' @name st_as_sftime #' @param long A logical value; See \code{\link[stars:st_as_sf]{st_as_sf}}. #' Typically, \code{long} should be set to \code{TRUE} since time information #' typically is a dimension of a \code{stars} object. #' @examples #' # convert a Tracks object from package trajectories to an sftime object #' x5_stars <- stars::read_stars(system.file("nc/bcsd_obs_1999.nc", package = "stars")) #' x5_sftime <- st_as_sftime(x5_stars, time_column_name = "time") #' #' # this requires some thought to not accidentally drop time dimensions. For #' # example, setting `merge = TRUE` will drop the time dimension and thus throw #' # an error: #' \dontrun{ #' x5_sftime <- st_as_sftime(x5_stars, merge = TRUE, time_column_name = "time") #' } #' #' @export st_as_sftime.stars <- function(x, ..., long = TRUE, time_column_name = NULL) { res <- sf::st_as_sf(x, ..., long = long) if(!time_column_name %in% colnames(res)) stop("`time_column_name` is not a column in the converted object.") st_sftime(res, time_column_name = time_column_name) } #' @name st_as_sftime #' @param agr A character vector; see the details section of \code{\link[sf]{st_sf}}. #' @param coords In case of point data: names or numbers of the numeric columns #' holding coordinates. #' @param wkt The name or number of the character column that holds WKT encoded #' geometries. #' @param dim Passed on to \code{\link[sf]{st_point}} (only when argument #' \code{coords} is given). #' @param remove A logical value; when \code{coords} or \code{wkt} is given, #' remove these columns from \code{x}? #' @param na.fail A logical value; if \code{TRUE}, raise an error if coordinates #' contain missing values. #' @inheritParams st_sftime #' @examples #' # convert a data frame to an sftime object #' x5_df <- #' data.frame(a = 1:5, g, time = Sys.time() + 1:5, stringsAsFactors = FALSE) #' x5_sftime <- st_as_sftime(x5_df) #' #' @export st_as_sftime.data.frame <- function(x, ..., agr = NA_agr_, coords, wkt, dim = "XYZ", remove = TRUE, na.fail = TRUE, sf_column_name = NULL, time_column_name = NULL, time_column_last = FALSE) { st_sftime( sf::st_as_sf( x, ..., agr = agr, coords = coords, wkt = wkt, dim = dim, remove = remove, na.fail = na.fail, sf_column_name = sf_column_name ), time_column_name = time_column_name, time_column_last = time_column_last ) } #' @name st_as_sftime #' @examples #' # convert a ppp object to an sftime object (modified from the sf package) #' if (require(spatstat.geom)) { #' st_as_sftime(gorillas, time_column_name = "date") #' } #' #' @export st_as_sftime.ppp <- function(x, ..., time_column_name) { st_sftime(sf::st_as_sf(x), time_column_name = time_column_name) } #' @name st_as_sftime #' @examples #' # convert a psp object to an sftime object (modified from the spatstat.geom #' # package) #' if (require(spatstat.geom)) { #' # modified from spatstat.geom: #' x_psp <- #' psp( #' runif(10), runif(10), runif(10), runif(10), window=owin(), #' marks = data.frame(time = Sys.time() + 1:10) #' ) #' st_as_sftime(x_psp, time_column_name = "time") #' } #' #' @export st_as_sftime.psp <- function(x, ..., time_column_name) { st_sftime(sf::st_as_sf(x), time_column_name = time_column_name) } #' @name st_as_sftime #' @examples #' # convert an lpp object to an sftime object (modified from the #' # spatstat.linnet package) #' if (require(spatstat.geom) && require(spatstat.linnet)) { #' # modified from spatstat.linnet: #' #' # letter 'A' #' v <- spatstat.geom::ppp(x=(-2):2, y=3*c(0,1,2,1,0), c(-3,3), c(-1,7)) #' edg <- cbind(1:4, 2:5) #' edg <- rbind(edg, c(2,4)) #' letterA <- spatstat.linnet::linnet(v, edges=edg) #' #' # points on letter A #' xx <- #' spatstat.geom::ppp( #' x=c(-1.5,0,0.5,1.5), y=c(1.5,3,4.5,1.5), #' marks = data.frame(time = Sys.time() + 1:4, a = 1:4), #' window = spatstat.geom::owin( #' xrange = range(c(-1.5,0,0.5,1.5)), #' yrange = range(c(1.5,3,4.5,1.5))) #' ) #' x_lpp <- spatstat.linnet::lpp(xx, letterA) #' #' # convert to sftime #' st_as_sftime(x_lpp, time_column_name = "time") #' } #' #' @export st_as_sftime.lpp <- function(x, ..., time_column_name) { st_sftime(sf::st_as_sf(x), time_column_name = time_column_name) } #' @name st_as_sftime #' @examples #' # convert an sftrack object to an sftime object (modified from sftrack) #' if (require(sftrack)) { #' #' # get an sftrack object #' data("raccoon") #' #' raccoon$timestamp <- as.POSIXct(raccoon$timestamp, "EST") #' #' burstz <- #' list(id = raccoon$animal_id, month = as.POSIXlt(raccoon$timestamp)$mon) #' #' x_sftrack <- #' as_sftrack(raccoon, #' group = burstz, time = "timestamp", #' error = NA, coords = c("longitude", "latitude") #' ) #' #' # convert to sftime #' st_as_sftime(x_sftrack) #' } #' #' @export st_as_sftime.sftrack <- function(x, ...) { time_column_name <- attr(x, which = "time_column") attr(x, which = "group_col") <- NULL attr(x, which = "error_col") <- NULL class(x) <- setdiff(class(x), "sftrack") st_sftime(x, time_column_name = time_column_name) } #' @name st_as_sftime #' @examples #' # convert an sftraj object to an sftime object (modified from sftrack) #' if (require(sftrack)) { #' #' # get an sftrack object #' data("raccoon") #' #' raccoon$timestamp <- as.POSIXct(raccoon$timestamp, "EST") #' #' burstz <- #' list(id = raccoon$animal_id, month = as.POSIXlt(raccoon$timestamp)$mon) #' #' x_sftraj <- #' as_sftraj(raccoon, #' time = "timestamp", #' error = NA, coords = c("longitude", "latitude"), #' group = burstz #' ) #' #' # convert to sftime #' st_as_sftime(x_sftraj) #' } #' #' @export st_as_sftime.sftraj <- function(x, ...) { time_column_name <- attr(x, which = "time_column") attr(x, which = "group_col") <- NULL attr(x, which = "error_col") <- NULL class(x) <- setdiff(class(x), "sftraj") st_sftime(x, time_column_name = time_column_name) } #' @name st_as_sftime #' @inheritParams cubble::make_spatial_sf #' @examples #' # convert a cubble_df object from package cubble to an sftime object #' if (requireNamespace("cubble", quietly = TRUE, versionCheck = list(op = ">=", version = "0.3.0"))) { #' #' # get a cubble_df object #' data("climate_aus", package = "cubble") #' #' # convert to sftime #' climate_aus_sftime <- #' st_as_sftime(climate_aus[1:4, ]) #' #' climate_aus_sftime <- #' st_as_sftime(cubble::face_temporal(climate_aus)[1:4, ]) #' #' } #' @export st_as_sftime.cubble_df <- function(x, ..., sfc = NULL, crs, silent = FALSE) { if (! requireNamespace("cubble", quietly = TRUE, versionCheck = list(op = ">=", version = "0.3.0"))) stop("You need the `cubble` package (>= 0.3.0) to use this function. Install that first.") # make sure the cubble_df object has the right format if(! cubble::is_cubble_spatial(x)) { x <- cubble::face_spatial(data = x) } if(! inherits(x, "sf")) { x <- cubble::make_spatial_sf(x, sfc = sfc, crs = crs, silent = silent) } # extract information needed to create the sftime object time_column_name <- attr(x, which = "index") id_column_name <- utils::head(names(attr(x, "key")), -1) column_names <- c(setdiff(colnames(x), "ts"), colnames(x$ts[[1]])) x_ts <- as.data.frame(cubble::face_temporal(x, col = "ts")) # convert to sf (drop all cubble_df attributes) attr(x, which = "form") <- NULL attr(x, which = "coords") <- NULL attr(x, which = "index") <- NULL class(x) <- setdiff(class(x), c("cubble_df", "spatial_cubble_df")) # merge spatial and temporal faces x <- merge(x_ts, x[, !colnames(x) == "ts"], by = id_column_name) x <- x[, column_names] st_as_sftime(x, time_column_name = time_column_name) } #### transform attributes #### #' Transform method for \code{sftime} objects #' #' Can be used to create or modify attribute variables; for transforming #' geometries see \code{\link[sf]{st_transform}}, and all other functions starting with #' \code{st_}. #' #' @param _data An object of class \code{\link[=st_sftime]{sftime}}. #' @inheritParams sf::transform.sf #' #' @return \code{_data} (an \code{sftime} object) with modified attribute values #' (columns). #' #' @examples #' # create an sftime object #' g <- st_sfc(st_point(c(1, 2)), st_point(c(1, 3)), st_point(c(2, 3)), #' st_point(c(2, 1)), st_point(c(3, 1))) #' x <- #' data.frame(a = 1:5, g, time = Sys.time() + 1:5, stringsAsFactors = FALSE) #' x_sftime <- st_as_sftime(x) #' x_sftime #' #' # modify values in column a #' transform(x_sftime, a = rev(a)) #' #' @export transform.sftime <- function (`_data`, ...) { reclass_sftime(NextMethod(), time_column_name = attr(`_data`, "time_column")) } sftime/R/init.R 0000644 0001762 0000144 00000005223 14424431542 013035 0 ustar ligges users #' @import sf NULL # from: https://github.com/cran/sf/blob/master/R/tidyverse.R: # from: https://github.com/tidyverse/hms/blob/master/R/zzz.R # Thu Apr 19 10:53:24 CEST 2018 register_s3_method <- function(pkg, generic, class, fun = NULL) { stopifnot(is.character(pkg), length(pkg) == 1) stopifnot(is.character(generic), length(generic) == 1) stopifnot(is.character(class), length(class) == 1) if (is.null(fun)) { fun <- get(paste0(generic, ".", class), envir = parent.frame()) } else { stopifnot(is.function(fun)) } if (pkg %in% loadedNamespaces()) { registerS3method(generic, class, fun, envir = asNamespace(pkg)) } # Always register hook in case package is later unloaded & reloaded setHook( packageEvent(pkg, "onLoad"), function(...) { registerS3method(generic, class, fun, envir = asNamespace(pkg)) } ) } register_all_s3_methods <- function() { # tidyverse joins register_s3_method("dplyr", "inner_join", "sftime") register_s3_method("dplyr", "left_join", "sftime") register_s3_method("dplyr", "right_join", "sftime") register_s3_method("dplyr", "full_join", "sftime") register_s3_method("dplyr", "semi_join", "sftime") register_s3_method("dplyr", "anti_join", "sftime") register_s3_method("dplyr", "filter", "sftime") register_s3_method("dplyr", "arrange", "sftime") register_s3_method("dplyr", "distinct", "sftime") register_s3_method("dplyr", "group_by", "sftime") register_s3_method("dplyr", "mutate", "sftime") register_s3_method("dplyr", "dplyr_reconstruct", "sftime") register_s3_method("dplyr", "rename", "sftime") register_s3_method("dplyr", "rowwise", "sftime") register_s3_method("dplyr", "sample_frac", "sftime") register_s3_method("dplyr", "sample_n", "sftime") register_s3_method("dplyr", "select", "sftime") register_s3_method("dplyr", "slice", "sftime") register_s3_method("dplyr", "summarise", "sftime") register_s3_method("dplyr", "summarize", "sftime") register_s3_method("dplyr", "transmute", "sftime") register_s3_method("dplyr", "ungroup", "sftime") register_s3_method("tidyr", "gather", "sftime") register_s3_method("tidyr", "pivot_longer", "sftime") register_s3_method("tidyr", "spread", "sftime") register_s3_method("tidyr", "nest", "sftime") register_s3_method("tidyr", "separate", "sftime") register_s3_method("tidyr", "separate_rows", "sftime") register_s3_method("tidyr", "unite", "sftime") register_s3_method("tidyr", "unnest", "sftime") register_s3_method("tidyr", "drop_na", "sftime") } .onLoad <- function(libname, pkgname) { register_all_s3_methods() } sftime/R/crop.R 0000644 0001762 0000144 00000002007 14232675654 013045 0 ustar ligges users #' Crop an \code{sftime} object to a specific rectangle #' #' @param x An object of class \code{sftime}. #' @param y A numeric vector with named elements \code{xmin}, \code{ymin}, #' \code{xmax} and \code{ymax}, or an object of class \code{bbox}, or an object #' for which there is an \code{\link[sf:st_bbox]{st_bbox}} method to convert it #' to a \code{bbox} object. #' @param ... Additional arguments; Ignored. #' @return \code{x} cropped using \code{y}. #' @details #' See \code{\link[sf:st_crop]{st_crop}}. #' @examples #' # modified from sf: #' box <- c(xmin = 0, ymin = 0, xmax = 1, ymax = 1) #' pol <- sf::st_sfc(sf::st_buffer(sf::st_point(c(0.5, 0.5)), 0.6)) #' pol_sftime <- st_sftime(a = 1, geom = pol, time = Sys.time() + 1:2 * 1000) #' #' pol_sftime_cropped <- sf::st_crop(pol_sftime, sf::st_bbox(box)) #' #' class(pol_sftime_cropped) #' plot(pol_sftime_cropped) #' @export st_crop.sftime <- function(x, y, ...) { reclass_sftime(NextMethod(), time_column_name = attr(x, "time_column")) } sftime/R/bind.R 0000644 0001762 0000144 00000007125 15175611736 013022 0 ustar ligges users #' Bind rows (features) of \code{sftime} objects #' #' @name bind #' @param ... Objects to bind; note that for the \code{rbind} and \code{cbind} #' methods, all objects have to be of class \code{sftime}; see #' \code{\link{dotsMethods}}. #' @param deparse.level An integer value; see \code{\link{rbind}}. #' @return \code{rbind} combines all \code{sftime} objects in \code{...} #' row-wise and returns the combined \code{sftime} object. #' @details Both \code{rbind} and \code{cbind} have non-standard method dispatch #' (see \link[base]{cbind}): the \code{rbind} or \code{cbind} method for #' \code{sftime} objects is only called when all arguments to be combined are of #' class \code{sftime}. #' @export #' @examples #' g1 <- st_sfc(st_point(1:2)) #' x1 <- st_sftime(a = 3, geometry = g1, time = Sys.time()) #' #' g2 <- st_sfc(st_point(c(4, 6))) #' x2 <- st_sftime(a = 4, geometry = g2, time = Sys.time()) #' #' rbind(x1, x2) # works because both tc1 and tc2 have the same class #' #' \dontrun{ #' st_time(x2) <- 1 #' rbind(x1, x2) # error because both tc1 and tc2 do not have the same class #' } #' rbind.sftime <- function(..., deparse.level = 1) { dots <- list(...) dots <- dots[!sapply(dots, is.null)] stopifnot(vapply(dots, inherits, "sftime", FUN.VALUE = TRUE)) tc0 <- class(st_time(dots[[1]])) if (length(dots) > 1L) { # check all time columns are equal... equal_tc <- vapply(dots[-1L], function(x) identical(tc0, class(st_time(x))), TRUE) if (!all(equal_tc)) stop("Arguments have different time column classes", call. = FALSE) } nr <- sapply(dots, NROW) tc_column <- if (any(nr > 0)) attr(dots[[ which(nr > 0)[1] ]], "tc_column") else NULL st_sftime(do.call(rbind, lapply(dots, function(x) structure(x, class = setdiff(class(x), "sftime")))), time_column_name = tc_column) } #' Bind columns (variables) of \code{sftime} objects #' #' @name bind #' @param sf_column_name Character value; specifies the active geometry column; #' passed on to \code{\link{st_sftime}}. #' @param tc_column_name Character value; specifies active time column; passed #' on to \code{\link{st_sftime}}. #' @return \code{cbind} combines all \code{sftime} objects in \code{...} #' column-wise and returns the combined \code{sftime} object. When called with #' multiple \code{sftime} objects warns about multiple time and geometry columns #' present when the time and geometry columns to use are not specified by using #' arguments \code{tc_column_name} and \code{sf_column_name}; see also #' \link{st_sftime}. #' @export #' @details If you need to \code{cbind} e.g. a \code{data.frame} to an \code{sf}, #' use \code{\link{data.frame}} directly and use \code{\link{st_sftime}} on its #' result, or use \code{\link[dplyr:bind]{bind_cols}}; see examples. #' @examples #' cbind(x1, x2) #' #' if (require(dplyr)) { #' # returns a data frame because names of sf and time column are modified: #' dplyr::bind_cols(x1, x2) #' #' # returns an sf object because the name of the time column is modified: #' dplyr::bind_cols(x1, x2 |> sf::st_drop_geometry()) #' #' # returns an sftime object because names of sf and time column are both #' # preserved: #' dplyr::bind_cols(x1, x2 |> st_drop_time() |> sf::st_drop_geometry()) #' } #' #' df <- data.frame(x = 3) #' st_sftime(data.frame(x1, df)) #' cbind.sftime = function(..., deparse.level = 1, sf_column_name = NULL, tc_column_name = NULL) { st_sftime(data.frame(...), sf_column_name = sf_column_name, time_column_name = tc_column_name) } sftime/R/join.R 0000644 0001762 0000144 00000013733 14232675654 013051 0 ustar ligges users #' Helper function to adjust class and attributes of \code{sftime} objects when joining #' #' @param x An object to be reclassed to the \code{\link[=st_sftime]{sftime}} #' class. #' @param time_colmn_name A character value; name of the original active time #' column in \code{x} before joining. #' @param suffix_x A character value representing the suffix to add to the name #' of the time column in the \code{time_column} attribute when name repair #' during joining changed the name of the time column. #' #' @return \code{x} as \code{sftime} object with adjusted \code{time_column} #' attribute. #' #' @keywords internal #' @noRd sftime_join <- function(x, time_column_name, suffix_x = ".x") { if (!(time_column_name %in% names(x))) { time_column_name <- paste0(time_column_name, suffix_x) stopifnot(time_column_name %in% names(x)) } st_as_sftime(x, time_column_name = time_column_name) } ## Tidyverse joins (see also tidyverse.R) #' @name tidyverse #' @examples #' g1 <- st_sfc(st_point(1:2), st_point(c(5, 8)), st_point(c(2, 9))) #' x1 <- st_sftime(a = 1:3, geometry = g1, time = Sys.time()) #' #' g2 <- st_sfc(st_point(c(4, 6)), st_point(c(4, 6)), st_point(c(4, 6))) #' x2 <- st_sftime(a = 2:4, geometry = g2, time = Sys.time()) #' #' library(dplyr) #' #' ## inner_join #' inner_join(x1, as.data.frame(x2), by = "a") # note: the active time column is #' # time.x and the active geometry column geometry.x #' #' inner_join(x2, as.data.frame(x1), by = "a") #' inner_join.sftime <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { sftime_join(NextMethod(), time_column_name = attr(x, "time_column"), suffix_x = suffix[[1]]) } #' @name tidyverse #' @examples #' ## left_join #' left_join(x1, as.data.frame(x2), by = "a") #' #' left_join(x2, as.data.frame(x1), by = "a") #' left_join.sftime <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { sftime_join(NextMethod(), time_column_name = attr(x, "time_column"), suffix_x = suffix[[1]]) } #' @name tidyverse #' @examples #' ## right_join #' right_join(x1, as.data.frame(x2), by = "a") #' #' right_join(x2, as.data.frame(x1), by = "a") #' right_join.sftime <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { sftime_join(NextMethod(), time_column_name = attr(x, "time_column"), suffix_x = suffix[[1]]) } #' @name tidyverse #' @examples #' ## full_join #' full_join(x1, as.data.frame(x2), by = "a") #' #' full_join(x2, as.data.frame(x1), by = "a") #' full_join.sftime <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { sftime_join(NextMethod(), time_column_name = attr(x, "time_column"), suffix_x = suffix[[1]]) } #' @name tidyverse #' @examples #' ## semi_join #' semi_join(x1, as.data.frame(x2), by = "a") #' #' semi_join(x2, as.data.frame(x1), by = "a") #' semi_join.sftime <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { sftime_join(NextMethod(), time_column_name = attr(x, "time_column"), suffix_x = suffix[[1]]) } #' @name tidyverse #' @examples #' ## anti_join #' anti_join(x1, as.data.frame(x2), by = "a") #' #' anti_join(x2, as.data.frame(x1), by = "a") #' anti_join.sftime <- function(x, y, by = NULL, copy = FALSE, suffix = c(".x", ".y"), ...) { sftime_join(NextMethod(), time_column_name = attr(x, "time_column"), suffix_x = suffix[[1]]) } #' Spatial join, spatial filter for \code{sftime} objects #' #' @name st_join #' @param x An object of class \code{sftime} or \code{sf}. #' @param y An object of class \code{sftime} or \code{sf}. #' @param join A geometry predicate function with the same profile as #' \code{\link[sf:geos_binary_pred]{st_intersects}}; see details. #' @inheritParams sf::st_join #' @return An object of class \code{sftime}, joined based on geometry. #' @details Alternative values for argument \code{join} are: #' \itemize{ #' \item \link[sf:geos_binary_pred]{st_contains_properly} #' \item \link[sf:geos_binary_pred]{st_contains} #' \item \link[sf:geos_binary_pred]{st_covered_by} #' \item \link[sf:geos_binary_pred]{st_covers} #' \item \link[sf:geos_binary_pred]{st_crosses} #' \item \link[sf:geos_binary_pred]{st_disjoint} #' \item \link[sf:geos_binary_pred]{st_equals_exact} #' \item \link[sf:geos_binary_pred]{st_equals} #' \item \link[sf:geos_binary_pred]{st_is_within_distance} #' \item \link[sf:geos_binary_pred]{st_nearest_feature} #' \item \link[sf:geos_binary_pred]{st_overlaps} #' \item \link[sf:geos_binary_pred]{st_touches} #' \item \link[sf:geos_binary_pred]{st_within} #' \item any user-defined function of the same profile as the above #' } #' A left join returns all records of the \code{x} object with \code{y} fields #' for non-matched records filled with \code{NA} values; an inner join returns #' only records that spatially match. #' #' @examples #' g1 <- st_sfc(st_point(c(1,1)), st_point(c(2,2)), st_point(c(3,3))) #' x1 <- st_sftime(a = 1:3, geometry = g1, time = Sys.time()) #' #' g2 <- st_sfc(st_point(c(10,10)), st_point(c(2,2)), st_point(c(2,2)), st_point(c(3,3))) #' x2 <- st_sftime(a = 11:14, geometry = g2, time = Sys.time()) #' #' ## st_join #' #' # left spatial join with st_intersects #' st_join(x1, x2) #' #' # inner spatial join with st_intersects #' st_join(x1, x2, left = FALSE) #' #' @export st_join.sftime <- function(x, y, join = st_intersects, ..., suffix = c(".x", ".y"), left = TRUE, largest = FALSE) { sftime_join(NextMethod(), time_column_name = attr(x, "time_column"), suffix_x = suffix[[1]]) } #' @name st_join #' @param .predicate A geometry predicate function with the same profile as #' \code{\link[sf:geos_binary_pred]{st_intersects}}; see details. #' @examples #' ## st_filter #' #' st_filter(x1, x2) #' st_filter(x2, x1) #' #' @export st_filter.sftime <- function(x, y, ..., .predicate = st_intersects) { reclass_sftime(NextMethod(), time_column_name = attr(x, "time_column")) } sftime/vignettes/ 0000755 0001762 0000144 00000000000 15177167670 013572 5 ustar ligges users sftime/vignettes/sftime.Rmd 0000644 0001762 0000144 00000031373 15175615116 015523 0 ustar ligges users --- title: "Introduction to sftime" author: "Henning Teickner, Benedikt Gräler, Edzer Pebesma" date: "`r Sys.Date()`" output: rmarkdown::html_vignette vignette: > %\VignetteIndexEntry{Introduction to sftime} %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- ```{r setup, include = FALSE} knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ``` The package `sftime` extends package `sf` to store and handle spatiotemporal data. To this end, `sftime` introduces a dedicated time column that stores the temporal information alongside the simple features column of an `sf` object. The time column can consists of any collection of a class that allows to be sorted - reflecting the native order of time. Besides well-known time classes such as `Date` or `POSIXct`, it also allows for custom class definitions that come with the necessary methods to make sorting work (we will see a example below). This vignette briefly explains and illustrates the ideas and decisions behind the implementation of `sftime`. ```{r packages} # load required packages library(sftime) library(sf) library(stars) library(spacetime) library(ggplot2) library(tidyr) ``` ## The `sftime` class An `sftime` object is an `sf` object with an additional time column that contains the temporal information alongside the simple features column. This allows it to handle irregular and regular temporal information. For spatiotemporal data with regular temporal data (raster or vector data cubes: data where each geometry is observed at the same set of time instances), package `stars` is developed as a powerful alternative (e.g. time series of remote sensing imagery, regular measurements of entire measurement network). `sftime` fills the gap for data where arbitrary combinations of geometry and time occur, including irregularly collected sensor data or (spatiotemporal) point pattern data. `sftime` objects can be constructed directly from `sfc` objects by combining them with a vector representing temporal information: ```{r sftime-class-1} # example sfc object x_sfc <- sf::st_sfc( sf::st_point(1:2), sf::st_point(c(1,3)), sf::st_point(2:3), sf::st_point(c(2,1)) ) # create an sftime object directly from x_sfc x_sftime1 <- sftime::st_sftime(a = 1:4, x_sfc, time = Sys.time()- 0:3 * 3600 * 24) # first create the sf object and from this the sftime object x_sf <- sf::st_sf(a = 1:4, x_sfc, time = x_sftime1$time) x_sftime2 <- sftime::st_sftime(x_sf) x_sftime3 <- sftime::st_as_sftime(x_sf) # alernative option identical(x_sftime1, x_sftime2) identical(x_sftime1, x_sftime3) x_sftime1 ``` Methods for `sftime` objects are: ```{r sftime-class-2} methods(class = "sftime") ``` Methods for `sf` objects which are not listed above work also for `sftime` objects. ## Functions to get or set the time column of an `sftime` object Functions to get or set the time column of an `sftime` object are: ```{r time-column-1} # get the values from the time column st_time(x_sftime1) x_sftime1$time # alternative way # set the values in the time column st_time(x_sftime1) <- Sys.time() st_time(x_sftime1) # drop the time column to convert an sftime object to an sf object st_drop_time(x_sftime1) x_sftime1 # add a time column to an sf object converts it to an sftime object st_time(x_sftime1, time_column_name = "time") <- Sys.time() class(x_sftime1) # These can also be used with pipes x_sftime1 <- x_sftime1 |> st_drop_time() |> st_set_time(Sys.time(), time_column_name = "time") ``` ## Conversion to class `sftime` sftime supports coercion to `sftime` objects from the following classes (grouped according to packages): - sf: sf - stars: stars - spacetime: STI, STIDF - trajectories: Track, Tracks, TracksCollection - sftrack: sftrack, sftraj - cubble: cubble_df **Conversion from `sf` objects:** ```{r} # define the geometry column g <- st_sfc( st_point(c(1, 2)), st_point(c(1, 3)), st_point(c(2, 3)), st_point(c(2, 1)), st_point(c(3, 1)) ) # crate sf object x4_sf <- st_sf(a = 1:5, g, time = Sys.time() + 1:5) # convert to sftime x4_sftime <- st_as_sftime(x4_sf) class(x4_sftime) ``` **Conversion from `stars` objects:** ```{r} # load sample data x5_stars <- stars::read_ncdf(system.file("nc/bcsd_obs_1999.nc", package = "stars"), var = c("pr", "tas")) # convert to sftime x5_sftime <- st_as_sftime(x5_stars, time_column_name = "time") ``` `st_as_sftime.stars` is a wrapper around `st_as_sf.stars`. As a consequence, some dimensions of the `stars` object can be dropped during conversion. Temporal information in `stars` objects are typically stored as dimension of an attribute. Therefore, some argument settings to `st_as_sftime` can drop the dimension with temporal information and therefore throw an error. For example, setting `merge = TRUE` drops dimension `time` and therefore conversion fails. Similarly, setting `long = FALSE` returns the attribute values in a wide format, where each column is a time point: ```{r, error = TRUE} # failed conversion to sftime x5_sftime <- st_as_sftime(x5_stars, merge = TRUE, time_column_name = "time") x5_sftime <- st_as_sftime(x5_stars, long = FALSE, time_column_name = "time") ``` **Conversion from `spacetime` objects** ```{r} # get sample data example(STI, package = "spacetime") class(stidf) # conversion to sftime x1_sftime <- st_as_sftime(stidf) ``` **Conversion from `Track`, `Tracks`, `TracksCollections` objects (trajectories package)** ```{r} # get a sample TracksCollection x2_TracksCollection <- trajectories::rTracksCollection(p = 2, m = 3, n = 40) # convert to sftime x2_TracksCollection_sftime <- st_as_sftime(x2_TracksCollection) x2_Tracks_sftime <- st_as_sftime(x2_TracksCollection@tracksCollection[[1]]) x2_Track_sftime <- st_as_sftime(x2_TracksCollection@tracksCollection[[1]]@tracks[[1]]) ``` **Conversion from `cubble_df` objects** Both, nested and long-form `cubble_df` can be converted to class `sftime`. If the `cubble_df` object has no simple features column (is not also of class `sf`), the function first converts longitude and latitude to a simple features column using `cubble::add_geometry_column()`. ```{r, eval=TRUE, echo=TRUE} # get a sample cubble_df object climate_aus <- cubble::climate_aus # convert to sftime climate_aus_sftime <- st_as_sftime(climate_aus[1:4, ]) climate_aus_sftime <- st_as_sftime(cubble::face_temporal(climate_aus)[1:4, ]) ``` ## Subsetting Different subsetting methods exist for `sftime` objects. Since `sftime` objects are built on top of `sf` objects, all subsetting methods for `sf` objects also work for `sftime` objects. Above (section [The `sftime` class]), the method to subset the time column was introduced: ```{r} st_time(x_sftime1) ``` Other subsetting functions work as for `sf` objects, e.g. selecting rows by row indices returns the specified rows. A key difference is that the active time column of an `sftime` object is not sticky --- in contrast to the active simple feature column in `sf` objects. Therefore, the active time column of an `sftime` object always has to be selected explicitly. If omitted, the subset will simplify to an `sf` objects without the active time column: ```{r} # selecting rows and columns (works just as for sf objects) x_sftime1[1, ] x_sftime1[, 3] # beware: the time column is not sticky. If omitted, the subset becomes an sf object class(x_sftime1[, 1]) class(x_sftime1["a"]) # the same x_sftime1[, 1] # to retain the time column and an sftime object, explicitly select the time column during subsetting: class(x_sftime1[, c(1, 3)]) class(x_sftime1[c("a", "time")]) # the same ``` ## Plotting For quick plotting, a plot method exists for `sftime` objects, which plots longitude-latitude coordinates and colors simple features according to values of a specified variable. Different panels are plotted for different time intervals which can be specified. Simple feature geometries might be overlaid several times when multiple observations fall in the same time interval. This is similar to `stplot()` from package spacetime with `mode = "xy"`: ```{r plotting-plot.sftime-1, fig.width=7} coords <- matrix(runif(100), ncol = 2) g <- sf::st_sfc(lapply(1:50, function(i) st_point(coords[i, ]) )) x_sftime4 <- st_sftime( a = 1:200, b = rnorm(200), id_object = as.factor(rep(1:4,each=50)), geometry = g, time = as.POSIXct("2020-09-01 00:00:00") + 0:49 * 3600 * 6 ) plot(x_sftime4, key.pos = 4) ``` The plotting method internally uses the `plot` method for `sf` objects. This makes it possible to customize plot appearance using the arguments of `plot.sf()`, for example: ```{r plotting-plot.sftime-2, fig.width=7} plot(x_sftime4, number = 10, max.plot = 10, key.pos = 4) ``` To create customized plots or plots which have different variables on plot axes than longitude and latitude, we recommend using ggplot2. For example, the plot method output can be mimicked by: ```{r plotting-ggplot-1, fig.width=7} library(ggplot2) ggplot() + geom_sf(data = x_sftime4, aes(color = b)) + facet_wrap(~ cut_number(time, n = 6)) + theme( panel.spacing.x = unit(4, "mm"), panel.spacing.y = unit(4, "mm") ) ``` This strategy can also be used to create other plots, for example plotting the id of entities over time (similar to `stplot()` with `mode = "xt"`): ```{r plotting-ggplot-2, fig.width=7} ggplot(x_sftime4) + geom_point(aes(y = id_object, x = time, color = b)) ``` Or for plotting time series of values of all variables with different panels for each entity (location) defined via a categorical variable (similar to `stplot()` with `mode = "tp"`): ```{r plotting-ggplot-3, fig.width=7} x_sftime4 |> tidyr::pivot_longer(cols = c("a", "b"), names_to = "variable", values_to = "value") |> ggplot() + geom_path(aes(y = value, x = time, color = variable)) + facet_wrap(~ id_object) ``` Or for plotting time series of values of all variables for all entities defined via a categorical variable with different panels for each variable (similar to `stplot()` with `mode = "ts"`): ```{r plotting-ggplot-4, fig.width=7} x_sftime4 |> tidyr::pivot_longer(cols = c("a", "b"), names_to = "variable", values_to = "value") |> ggplot() + geom_path(aes(y = value, x = time, color = id_object)) + facet_wrap(~ variable, scales = "free_y") ``` ## User-defined time columns The time column is a special column of the underlying sf object which defines time information (timestamps and temporal ordering) alongside the simple features column of an sf object. Common time representations in R (e.g. `POSIXct`, `POSIXlt`, `Date`, `yearmon`, `yearqtr`) are allowed, as well as optional user-defined types. Let us look at a simple example where we define a time column based on `POSIXct` ```{r, eval=TRUE} (tc <- as.POSIXct("2020-09-01 08:00:00")-0:3*3600*24) ``` The ordering is not altered upon construction (as in some other representations). If a different order is required, the `order` function and `sort` method can be applied to the time column: ```{r} tc order(tc) sort(tc) ``` In some applications it might be useful to have more complex temporal information such as intervals of different length. The following example is also meant as template for other user-defined classes which could be used to build the time column of the sftime class. At first, we will need a few helper functions: ```{r} # utility functions as.character.interval <- function(x) { paste0("[", x[1], ", ", x[2], "]") } print.interval <- function(x, ...) { cat("Interval:", as.character(x), "\n") } #'[.intervals' <- function(x, i) { # sx <- unclass(x)[i] # class(sx) <- "intervals" # sx #} ``` Now, we can define the different intervals used to represent our temporal information: ```{r} # time interval definition i1 <- c(5.3,12) class(i1) <- "interval" i2 <- c(3.1,6) class(i2) <- "interval" i3 <- c(1.4,6.9) class(i3) <- "interval" i4 <- c(1,21) class(i4) <- "interval" intrvls <- structure(list(i1, i2, i3, i4), class = "Intervals") # provide dedicated generic to xtfrm for class intervals ``` The advantage is to be able to define different sorting approaches: ```{r} xtfrm.Intervals <- function(x) sapply(x, mean) # - sort by centre (tc <- intrvls) order(tc) sort(tc)[1] ``` ```{r} # - sort by end xtfrm.Intervals <- function(x) sapply(x, max) (tc <- intrvls) order(tc) sort(tc)[1] ``` ```{r} # - sort by start xtfrm.Intervals <- function(x) sapply(x, min) tc <- intrvls order(tc) sort(tc)[1] ``` Based on the sorting procedure (begin, centre or end of the interval), the smallest element (each last line) and the order of the time column changes. sftime/NAMESPACE 0000644 0001762 0000144 00000002413 14424426432 012765 0 ustar ligges users # Generated by roxygen2: do not edit by hand S3method("$<-",sftime) S3method("[",sftime) S3method("[[<-",sftime) S3method("st_time<-",sf) S3method("st_time<-",sftime) S3method(cbind,sftime) S3method(plot,sftime) S3method(print,sftime) S3method(rbind,sftime) S3method(st_as_sftime,ST) S3method(st_as_sftime,Track) S3method(st_as_sftime,Tracks) S3method(st_as_sftime,TracksCollection) S3method(st_as_sftime,cubble_df) S3method(st_as_sftime,data.frame) S3method(st_as_sftime,lpp) S3method(st_as_sftime,ppp) S3method(st_as_sftime,psp) S3method(st_as_sftime,sf) S3method(st_as_sftime,sftime) S3method(st_as_sftime,sftrack) S3method(st_as_sftime,sftraj) S3method(st_as_sftime,stars) S3method(st_cast,sftime) S3method(st_crop,sftime) S3method(st_difference,sftime) S3method(st_drop_geometry,sftime) S3method(st_filter,sftime) S3method(st_intersection,sftime) S3method(st_join,sftime) S3method(st_sym_difference,sftime) S3method(st_time,sftime) S3method(st_union,sftime) S3method(transform,sftime) export("st_time<-") export(is_sortable) export(st_as_sftime) export(st_drop_time) export(st_set_time) export(st_sftime) export(st_time) import(sf) importFrom(graphics,plot) importFrom(methods,as) importFrom(methods,slotNames) importFrom(utils,methods) sftime/NEWS.md 0000644 0001762 0000144 00000002426 15177161237 012655 0 ustar ligges users # sftime 0.3.2 * Switch from the magrittr pipe (`%>%`) to the R-native pipe (`|>`) in examples and vignettes (#15). # sftime 0.3.1 * Correct argument `versionCheck` the `requireNamespace` for the `cubble` package in `st_as_sftime.cubble_df()`. # sftime 0.3.0 * Add a dedicated `tidyr::drop_na()` method for `sftime` objects. (See the same recent addition for `sf` objects [#1975](https://github.com/r-spatial/sf/pull/1975/)). * Add a dedicated `dplyr::dplyr_reconstruct()` method for `sftime` objects. Relying on the method for `sf` objects caused erroneously column binding when the second object was a data frame without conflicting column names for the `sf` and time columns. In this case, a `sf` objects was returned, even though an `sftime` object should be returned. See also https://github.com/r-spatial/sf/issues/1958#issuecomment-1181982244. * Add methods to convert `sftime` objects from: + Objects from the `spatstat` package classes (`ppp`, `psp`, `lpp`) + `sftrack` and `sftraj` objects from the `sftrack` package. + `cubble_df` objects from the `cubble` package. * Bug fix in `st_time<-.sftime`: + Still contained references to the old `tc`class. + Did not allow to give the active time column a character vector as value. # version 0.2-0 * initial CRAN submission sftime/inst/ 0000755 0001762 0000144 00000000000 15177167667 012545 5 ustar ligges users sftime/inst/doc/ 0000755 0001762 0000144 00000000000 15177167667 013312 5 ustar ligges users sftime/inst/doc/sftime.html 0000644 0001762 0000144 00000364271 15177167666 015503 0 ustar ligges users
The package sftime extends package sf to
store and handle spatiotemporal data. To this end, sftime
introduces a dedicated time column that stores the temporal information
alongside the simple features column of an sf object.
The time column can consists of any collection of a class that allows
to be sorted - reflecting the native order of time. Besides well-known
time classes such as Date or POSIXct, it also
allows for custom class definitions that come with the necessary methods
to make sorting work (we will see a example below).
This vignette briefly explains and illustrates the ideas and
decisions behind the implementation of sftime.
# load required packages
library(sftime)
#> Loading required package: sf
#> Warning: package 'sf' was built under R version 4.5.3
#> Linking to GEOS 3.14.1, GDAL 3.12.1, PROJ 9.7.1; sf_use_s2() is TRUE
library(sf)
library(stars)
#> Warning: package 'stars' was built under R version 4.5.3
#> Loading required package: abind
#> Warning: package 'abind' was built under R version 4.5.2
library(spacetime)
#> Warning: package 'spacetime' was built under R version 4.5.3
library(ggplot2)
#> Warning: package 'ggplot2' was built under R version 4.5.2
library(tidyr)
#> Warning: package 'tidyr' was built under R version 4.5.2sftime classAn sftime object is an sf object with an
additional time column that contains the temporal information alongside
the simple features column. This allows it to handle irregular and
regular temporal information.
For spatiotemporal data with regular temporal data (raster or vector
data cubes: data where each geometry is observed at the same set of time
instances), package stars is developed as a powerful
alternative (e.g. time series of remote sensing imagery, regular
measurements of entire measurement network). sftime fills
the gap for data where arbitrary combinations of geometry and time
occur, including irregularly collected sensor data or (spatiotemporal)
point pattern data.
sftime objects can be constructed directly from
sfc objects by combining them with a vector representing
temporal information:
# example sfc object
x_sfc <-
sf::st_sfc(
sf::st_point(1:2),
sf::st_point(c(1,3)),
sf::st_point(2:3),
sf::st_point(c(2,1))
)
# create an sftime object directly from x_sfc
x_sftime1 <- sftime::st_sftime(a = 1:4, x_sfc, time = Sys.time()- 0:3 * 3600 * 24)
# first create the sf object and from this the sftime object
x_sf <- sf::st_sf(a = 1:4, x_sfc, time = x_sftime1$time)
x_sftime2 <- sftime::st_sftime(x_sf)
x_sftime3 <- sftime::st_as_sftime(x_sf) # alernative option
identical(x_sftime1, x_sftime2)
#> [1] TRUE
identical(x_sftime1, x_sftime3)
#> [1] TRUE
x_sftime1
#> Spatiotemporal feature collection with 4 features and 1 field
#> Geometry type: POINT
#> Dimension: XY
#> Bounding box: xmin: 1 ymin: 1 xmax: 2 ymax: 3
#> CRS: NA
#> Time column with classes: 'POSIXct', 'POSIXt'.
#> Ranging from 2026-05-04 22:01:56.057298 to 2026-05-07 22:01:56.057298.
#> a x_sfc time
#> 1 1 POINT (1 2) 2026-05-07 22:01:56
#> 2 2 POINT (1 3) 2026-05-06 22:01:56
#> 3 3 POINT (2 3) 2026-05-05 22:01:56
#> 4 4 POINT (2 1) 2026-05-04 22:01:56Methods for sftime objects are:
methods(class = "sftime")
#> [1] $<- [ [[<- cbind
#> [5] coerce drop_na filter gather
#> [9] initialize nest pivot_longer plot
#> [13] print rbind separate separate_rows
#> [17] show slotsFromS3 spread st_as_sftime
#> [21] st_cast st_crop st_difference st_drop_geometry
#> [25] st_filter st_intersection st_join st_sym_difference
#> [29] st_time st_time<- st_union transform
#> [33] unite unnest
#> see '?methods' for accessing help and source codeMethods for sf objects which are not listed above work
also for sftime objects.
sftime
objectFunctions to get or set the time column of an sftime
object are:
# get the values from the time column
st_time(x_sftime1)
#> [1] "2026-05-07 22:01:56 CEST" "2026-05-06 22:01:56 CEST"
#> [3] "2026-05-05 22:01:56 CEST" "2026-05-04 22:01:56 CEST"
x_sftime1$time # alternative way
#> [1] "2026-05-07 22:01:56 CEST" "2026-05-06 22:01:56 CEST"
#> [3] "2026-05-05 22:01:56 CEST" "2026-05-04 22:01:56 CEST"
# set the values in the time column
st_time(x_sftime1) <- Sys.time()
st_time(x_sftime1)
#> [1] "2026-05-07 22:01:56 CEST" "2026-05-07 22:01:56 CEST"
#> [3] "2026-05-07 22:01:56 CEST" "2026-05-07 22:01:56 CEST"
# drop the time column to convert an sftime object to an sf object
st_drop_time(x_sftime1)
#> Simple feature collection with 4 features and 1 field
#> Geometry type: POINT
#> Dimension: XY
#> Bounding box: xmin: 1 ymin: 1 xmax: 2 ymax: 3
#> CRS: NA
#> a x_sfc
#> 1 1 POINT (1 2)
#> 2 2 POINT (1 3)
#> 3 3 POINT (2 3)
#> 4 4 POINT (2 1)
x_sftime1
#> Spatiotemporal feature collection with 4 features and 1 field
#> Geometry type: POINT
#> Dimension: XY
#> Bounding box: xmin: 1 ymin: 1 xmax: 2 ymax: 3
#> CRS: NA
#> Time column with classes: 'POSIXct', 'POSIXt'.
#> Ranging from 2026-05-07 22:01:56.116356 to 2026-05-07 22:01:56.116356.
#> a x_sfc time
#> 1 1 POINT (1 2) 2026-05-07 22:01:56
#> 2 2 POINT (1 3) 2026-05-07 22:01:56
#> 3 3 POINT (2 3) 2026-05-07 22:01:56
#> 4 4 POINT (2 1) 2026-05-07 22:01:56
# add a time column to an sf object converts it to an sftime object
st_time(x_sftime1, time_column_name = "time") <- Sys.time()
class(x_sftime1)
#> [1] "sftime" "sf" "data.frame"
# These can also be used with pipes
x_sftime1 <-
x_sftime1 |>
st_drop_time() |>
st_set_time(Sys.time(), time_column_name = "time")sftimesftime supports coercion to sftime objects from the
following classes (grouped according to packages):
Conversion from sf objects:
# define the geometry column
g <-
st_sfc(
st_point(c(1, 2)),
st_point(c(1, 3)),
st_point(c(2, 3)),
st_point(c(2, 1)),
st_point(c(3, 1))
)
# crate sf object
x4_sf <- st_sf(a = 1:5, g, time = Sys.time() + 1:5)
# convert to sftime
x4_sftime <- st_as_sftime(x4_sf)
class(x4_sftime)
#> [1] "sftime" "sf" "data.frame"Conversion from stars objects:
# load sample data
x5_stars <- stars::read_ncdf(system.file("nc/bcsd_obs_1999.nc", package = "stars"), var = c("pr", "tas"))
#> Will return stars object with 32076 cells.
#> No projection information found in nc file.
#> Coordinate variable units found to be degrees,
#> assuming WGS84 Lat/Lon.
# convert to sftime
x5_sftime <- st_as_sftime(x5_stars, time_column_name = "time")st_as_sftime.stars is a wrapper around
st_as_sf.stars. As a consequence, some dimensions of the
stars object can be dropped during conversion. Temporal
information in stars objects are typically stored as
dimension of an attribute. Therefore, some argument settings to
st_as_sftime can drop the dimension with temporal
information and therefore throw an error. For example, setting
merge = TRUE drops dimension time and
therefore conversion fails. Similarly, setting long = FALSE
returns the attribute values in a wide format, where each column is a
time point:
# failed conversion to sftime
x5_sftime <- st_as_sftime(x5_stars, merge = TRUE, time_column_name = "time")
#> Error in `st_as_sftime.stars()`:
#> ! `time_column_name` is not a column in the converted object.
x5_sftime <- st_as_sftime(x5_stars, long = FALSE, time_column_name = "time")
#> Error in `st_as_sftime.stars()`:
#> ! `time_column_name` is not a column in the converted object.Conversion from spacetime objects
# get sample data
example(STI, package = "spacetime")
#>
#> STI> sp = cbind(x = c(0,0,1), y = c(0,1,1))
#>
#> STI> row.names(sp) = paste("point", 1:nrow(sp), sep="")
#>
#> STI> library(sp)
#> Warning: package 'sp' was built under R version 4.5.3
#>
#> STI> sp = SpatialPoints(sp)
#>
#> STI> time = as.POSIXct("2010-08-05")+3600*(10:13)
#>
#> STI> m = c(10,20,30) # means for each of the 3 point locations
#>
#> STI> mydata = rnorm(length(sp)*length(time),mean=rep(m, 4))
#>
#> STI> IDs = paste("ID",1:length(mydata))
#>
#> STI> mydata = data.frame(values = signif(mydata,3), ID=IDs)
#>
#> STI> stidf = as(STFDF(sp, time, mydata), "STIDF")
#>
#> STI> stidf[1:2,]
#> An object of class "STIDF"
#> Slot "data":
#> values ID
#> 1 9.24 ID 1
#> 2 22.40 ID 2
#>
#> Slot "sp":
#> SpatialPoints:
#> x y
#> point1 0 0
#> point2 0 1
#> Coordinate Reference System (CRS) arguments: NA
#>
#> Slot "time":
#> timeIndex
#> 2010-08-05 10:00:00 1
#> 2010-08-05 10:00:00 1
#>
#> Slot "endTime":
#> [1] "2010-08-05 11:00:00 CEST" "2010-08-05 11:00:00 CEST"
#>
#>
#> STI> all.equal(stidf, stidf[stidf,])
#> [1] TRUE
class(stidf)
#> [1] "STIDF"
#> attr(,"package")
#> [1] "spacetime"
# conversion to sftime
x1_sftime <- st_as_sftime(stidf)Conversion from Track, Tracks,
TracksCollections objects (trajectories
package)
# get a sample TracksCollection
x2_TracksCollection <- trajectories::rTracksCollection(p = 2, m = 3, n = 40)
# convert to sftime
x2_TracksCollection_sftime <- st_as_sftime(x2_TracksCollection)
x2_Tracks_sftime <- st_as_sftime(x2_TracksCollection@tracksCollection[[1]])
x2_Track_sftime <- st_as_sftime(x2_TracksCollection@tracksCollection[[1]]@tracks[[1]])Conversion from cubble_df objects
Both, nested and long-form cubble_df can be converted to
class sftime. If the cubble_df object has no
simple features column (is not also of class sf), the
function first converts longitude and latitude to a simple features
column using cubble::add_geometry_column().
# get a sample cubble_df object
climate_aus <- cubble::climate_aus
# convert to sftime
climate_aus_sftime <-
st_as_sftime(climate_aus[1:4, ])
#> CRS missing: using OGC:CRS84 (WGS84) as default
climate_aus_sftime <-
st_as_sftime(cubble::face_temporal(climate_aus)[1:4, ])
#> CRS missing: using OGC:CRS84 (WGS84) as defaultDifferent subsetting methods exist for sftime objects.
Since sftime objects are built on top of sf
objects, all subsetting methods for sf objects also work
for sftime objects.
Above (section The sftime
class), the method to subset the time column was introduced:
st_time(x_sftime1)
#> [1] "2026-05-07 22:01:56 CEST" "2026-05-07 22:01:56 CEST"
#> [3] "2026-05-07 22:01:56 CEST" "2026-05-07 22:01:56 CEST"Other subsetting functions work as for sf objects,
e.g. selecting rows by row indices returns the specified rows. A key
difference is that the active time column of an sftime
object is not sticky — in contrast to the active simple feature column
in sf objects.
Therefore, the active time column of an sftime object
always has to be selected explicitly. If omitted, the subset will
simplify to an sf objects without the active time
column:
# selecting rows and columns (works just as for sf objects)
x_sftime1[1, ]
#> Spatiotemporal feature collection with 1 feature and 1 field
#> Geometry type: POINT
#> Dimension: XY
#> Bounding box: xmin: 1 ymin: 2 xmax: 1 ymax: 2
#> CRS: NA
#> Time column with classes: 'POSIXct', 'POSIXt'.
#> Representing 2026-05-07 22:01:56.122308.
#> a x_sfc time
#> 1 1 POINT (1 2) 2026-05-07 22:01:56
x_sftime1[, 3]
#> Spatiotemporal feature collection with 4 features and 0 fields
#> Geometry type: POINT
#> Dimension: XY
#> Bounding box: xmin: 1 ymin: 1 xmax: 2 ymax: 3
#> CRS: NA
#> Time column with classes: 'POSIXct', 'POSIXt'.
#> Ranging from 2026-05-07 22:01:56.122308 to 2026-05-07 22:01:56.122308.
#> time x_sfc
#> 1 2026-05-07 22:01:56 POINT (1 2)
#> 2 2026-05-07 22:01:56 POINT (1 3)
#> 3 2026-05-07 22:01:56 POINT (2 3)
#> 4 2026-05-07 22:01:56 POINT (2 1)
# beware: the time column is not sticky. If omitted, the subset becomes an sf object
class(x_sftime1[, 1])
#> [1] "sf" "data.frame"
class(x_sftime1["a"]) # the same
#> [1] "sf" "data.frame"
x_sftime1[, 1]
#> Simple feature collection with 4 features and 1 field
#> Geometry type: POINT
#> Dimension: XY
#> Bounding box: xmin: 1 ymin: 1 xmax: 2 ymax: 3
#> CRS: NA
#> a x_sfc
#> 1 1 POINT (1 2)
#> 2 2 POINT (1 3)
#> 3 3 POINT (2 3)
#> 4 4 POINT (2 1)
# to retain the time column and an sftime object, explicitly select the time column during subsetting:
class(x_sftime1[, c(1, 3)])
#> [1] "sftime" "sf" "data.frame"
class(x_sftime1[c("a", "time")]) # the same
#> [1] "sftime" "sf" "data.frame"For quick plotting, a plot method exists for sftime
objects, which plots longitude-latitude coordinates and colors simple
features according to values of a specified variable. Different panels
are plotted for different time intervals which can be specified. Simple
feature geometries might be overlaid several times when multiple
observations fall in the same time interval. This is similar to
stplot() from package spacetime with
mode = "xy":
coords <- matrix(runif(100), ncol = 2)
g <- sf::st_sfc(lapply(1:50, function(i) st_point(coords[i, ]) ))
x_sftime4 <-
st_sftime(
a = 1:200,
b = rnorm(200),
id_object = as.factor(rep(1:4,each=50)),
geometry = g,
time = as.POSIXct("2020-09-01 00:00:00") + 0:49 * 3600 * 6
)
#> Warning in data.frame(..., check.names = FALSE): row names were found from a
#> short variable and have been discarded
plot(x_sftime4, key.pos = 4)#> NULL
The plotting method internally uses the plot method for
sf objects. This makes it possible to customize plot
appearance using the arguments of plot.sf(), for
example:
#> NULL
To create customized plots or plots which have different variables on plot axes than longitude and latitude, we recommend using ggplot2. For example, the plot method output can be mimicked by:
library(ggplot2)
ggplot() +
geom_sf(data = x_sftime4, aes(color = b)) +
facet_wrap(~ cut_number(time, n = 6)) +
theme(
panel.spacing.x = unit(4, "mm"),
panel.spacing.y = unit(4, "mm")
)This strategy can also be used to create other plots, for example
plotting the id of entities over time (similar to stplot()
with mode = "xt"):
Or for plotting time series of values of all variables with different
panels for each entity (location) defined via a categorical variable
(similar to stplot() with mode = "tp"):
x_sftime4 |>
tidyr::pivot_longer(cols = c("a", "b"), names_to = "variable", values_to = "value") |>
ggplot() +
geom_path(aes(y = value, x = time, color = variable)) +
facet_wrap(~ id_object)Or for plotting time series of values of all variables for all
entities defined via a categorical variable with different panels for
each variable (similar to stplot() with
mode = "ts"):
x_sftime4 |>
tidyr::pivot_longer(cols = c("a", "b"), names_to = "variable", values_to = "value") |>
ggplot() +
geom_path(aes(y = value, x = time, color = id_object)) +
facet_wrap(~ variable, scales = "free_y")The time column is a special column of the underlying sf object which
defines time information (timestamps and temporal ordering) alongside
the simple features column of an sf object. Common time representations
in R (e.g. POSIXct, POSIXlt,
Date, yearmon, yearqtr) are
allowed, as well as optional user-defined types. Let us look at a simple
example where we define a time column based on POSIXct
(tc <- as.POSIXct("2020-09-01 08:00:00")-0:3*3600*24)
#> [1] "2020-09-01 08:00:00 CEST" "2020-08-31 08:00:00 CEST"
#> [3] "2020-08-30 08:00:00 CEST" "2020-08-29 08:00:00 CEST"The ordering is not altered upon construction (as in some other
representations). If a different order is required, the
order function and sort method can be applied
to the time column:
tc
#> [1] "2020-09-01 08:00:00 CEST" "2020-08-31 08:00:00 CEST"
#> [3] "2020-08-30 08:00:00 CEST" "2020-08-29 08:00:00 CEST"
order(tc)
#> [1] 4 3 2 1
sort(tc)
#> [1] "2020-08-29 08:00:00 CEST" "2020-08-30 08:00:00 CEST"
#> [3] "2020-08-31 08:00:00 CEST" "2020-09-01 08:00:00 CEST"In some applications it might be useful to have more complex temporal information such as intervals of different length. The following example is also meant as template for other user-defined classes which could be used to build the time column of the sftime class.
At first, we will need a few helper functions:
# utility functions
as.character.interval <- function(x) {
paste0("[", x[1], ", ", x[2], "]")
}
print.interval <- function(x, ...) {
cat("Interval:", as.character(x), "\n")
}
#'[.intervals' <- function(x, i) {
# sx <- unclass(x)[i]
# class(sx) <- "intervals"
# sx
#}Now, we can define the different intervals used to represent our temporal information:
# time interval definition
i1 <- c(5.3,12)
class(i1) <- "interval"
i2 <- c(3.1,6)
class(i2) <- "interval"
i3 <- c(1.4,6.9)
class(i3) <- "interval"
i4 <- c(1,21)
class(i4) <- "interval"
intrvls <- structure(list(i1, i2, i3, i4), class = "Intervals")
# provide dedicated generic to xtfrm for class intervalsThe advantage is to be able to define different sorting approaches:
xtfrm.Intervals <- function(x) sapply(x, mean)
# - sort by centre
(tc <- intrvls)
#> [[1]]
#> Interval: [5.3, 12]
#>
#> [[2]]
#> Interval: [3.1, 6]
#>
#> [[3]]
#> Interval: [1.4, 6.9]
#>
#> [[4]]
#> Interval: [1, 21]
#>
#> attr(,"class")
#> [1] "Intervals"
order(tc)
#> [1] 3 2 1 4
sort(tc)[1]
#> [[1]]
#> Interval: [1.4, 6.9]# - sort by end
xtfrm.Intervals <- function(x) sapply(x, max)
(tc <- intrvls)
#> [[1]]
#> Interval: [5.3, 12]
#>
#> [[2]]
#> Interval: [3.1, 6]
#>
#> [[3]]
#> Interval: [1.4, 6.9]
#>
#> [[4]]
#> Interval: [1, 21]
#>
#> attr(,"class")
#> [1] "Intervals"
order(tc)
#> [1] 2 3 1 4
sort(tc)[1]
#> [[1]]
#> Interval: [3.1, 6]# - sort by start
xtfrm.Intervals <- function(x) sapply(x, min)
tc <- intrvls
order(tc)
#> [1] 4 3 2 1
sort(tc)[1]
#> [[1]]
#> Interval: [1, 21]Based on the sorting procedure (begin, centre or end of the interval), the smallest element (each last line) and the order of the time column changes.