Function addition to do conversions from and to sftime class

NAMESPACE

@@ -46,7 +46,7 @@ export(download_setup_dir)
 export(download_sink)
 export(download_tri_data)
 export(download_unzip)
-export(dt_to_mysftime)
+export(dt_as_mysftime)
 export(extract_urls)
 export(generate_date_sequence)
 export(is_date_proper)
@@ -65,10 +65,20 @@ export(process_nei)
 export(process_nlcd)
 export(process_tri)
 export(read_commands)
+export(sf_as_mysftime)
+export(sftime_as_mysftime)
+export(sftime_as_sf)
+export(sftime_as_spatraster)
+export(sftime_as_spatrds)
+export(sftime_as_spatvector)
+export(spatraster_as_sftime)
+export(spatrds_as_sftime)
+export(spatvector_as_sftime)
 export(test_download_functions)
 import(rvest)
 import(sf)
 import(sftime)
+import(stars)
 importFrom(data.table,.SD)
 importFrom(data.table,as.data.table)
 importFrom(data.table,fread)

R/manipulate_spacetime_data.R

@@ -165,14 +165,16 @@ check_mysf <- function(x) {
 #' @param latname character for latitude column name
 #' @param timename character for time column name
 #' @param crs coordinate reference system
+#' @return a sftime object
 #' @import sftime
 #' @author Eva Marques
 #' @export
-dt_to_mysftime <- function(x, lonname, latname, timename, crs) {
+dt_as_mysftime <- function(x, lonname, latname, timename, crs) {
   stopifnot("x is not a data.table" = class(x)[1] == "data.table")
   if (any(!(c(lonname, latname, timename) %in% colnames(x)))) {
     stop("Some of lon, lat, time columns missing or mispelled")
   }
+
   mysft <-
     sftime::st_as_sftime(
       x,
@@ -184,11 +186,154 @@ dt_to_mysftime <- function(x, lonname, latname, timename, crs) {
   return(mysft)
 }
 
+#' Create a sftime from a terra::SpatRaster
+#'
+#' @param x a terra::SpatRaster
+#' @param varname character for variable column name in the sftime
+#' @param timename character for time column name in the sftime
+#' (default: "time")
+#' @return a sftime object
+#' @import sftime
+#' @author Eva Marques
+#' @export
+spatraster_as_sftime <- function(x, varname, timename = "time") {
+  date_correct <- TRUE
+  tryCatch(
+    {
+      as.POSIXct(names(x))
+    },
+    error = function(e) {
+      date_correct <<- FALSE
+    }
+  )
+  stopifnot("x layers might not be time" = date_correct)
+  df <- as.data.frame(x, xy = TRUE)
+  output <- df |>
+    data.table::as.data.table() |>
+    data.table::melt(
+      measure.vars = names(df)[-1:-2],
+      variable.name = "time",
+      value.name = varname
+    ) |>
+    st_as_sftime(
+      coords = c("x", "y"),
+      time_column_name = "time",
+      crs = terra::crs(x)
+    )
+  names(output)[names(output) == "time"] <- timename
+  attributes(output)$time_column <- timename
+  return(output)
+}
+
+#' Create a sftime from a terra::SpatRasterDataset
+#'
+#' @param x a terra::SpatRasterDataset (~ list of named SpatRasters)
+#' @param timename character for time column name in the sftime
+#' (default: "time")
+#' @return a sftime object
+#' @import sftime
+#' @author Eva Marques
+#' @export
+spatrds_as_sftime <- function(x, timename = "time") {
+  stopifnot(
+    "x is not a SpatRasterDataset" =
+      class(x)[1] == "SpatRasterDataset"
+  )
+  variables <- names(x)
+  newsft <- spatraster_as_sftime(x[[variables[1]]],
+    varname = variables[1],
+    timename = timename
+  )
+  for (var in variables[2:length(variables)]) {
+    s <- spatraster_as_sftime(x[[var]],
+                              varname = var,
+                              timename = timename)
+    newsft[, var] <- st_drop_geometry(s[, var])
+  }
+  return(newsft)
+}
+
+#' Simplify an sftime to sf class
+#'
+#' @param x a sftime
+#' @param keeptime boolean: TRUE if user wants to keep time column
+#' as simple column (default = TRUE)
+#' @return a sf object
+#' @author Eva Marques
+#' @export
+sftime_as_sf <- function(x, keeptime = TRUE) {
+  stopifnot("x is not a sftime" = class(x)[1] == "sftime")
+  if (keeptime) {
+    timecol <- attributes(x)$time_column
+    output <- x[, !(colnames(x) %in% c(timecol))]
+    output[, timecol] <- as.data.table(x)[, get(timecol)]
+  } else {
+    output <- x
+    st_time(output) <- NULL
+  }
+  return(output)
+}
+
+#' Convert a sf object to mysftime
+#'
+#' @param x a sf
+#' @param timename character: name of time column in x
+#' @return a sftime object
+#' @author Eva Marques
+#' @export
+sf_as_mysftime <- function(x, timename) {
+  if (!(timename %in% colnames(x))) {
+    stop("time column missing or mispelled")
+  }
+  output <- st_as_sftime(x, time_column_name = timename)
+  attributes(output)$time_column <- "time"
+  output <- dplyr::rename(output, "time" = timename)
+  return(output)
+}
+
+#' Convert a sftime object to mysftime
+#'
+#' @param x a sftime
+#' @param timename character: name of time column in x
+#' @return a sftime object with specific format (see check_mysftime() function)
+#' @author Eva Marques
+#' @export
+sftime_as_mysftime <- function(x, timename) {
+  if (!(timename %in% colnames(x))) {
+    stop("time column missing or mispelled")
+  }
+  output <- x
+  attributes(output)$time_column <- "time"
+  output <- dplyr::rename(output, "time" = timename)
+  return(output)
+}
+
+#' Create a sftime from a terra::SpatVector
+#'
+#' @param x a terra::SpatVector
+#' @param timename character for time column name in x
+#' (default: "time")
+#' @return a sftime object
+#' @import sftime
+#' @author Eva Marques
+#' @export
+spatvector_as_sftime <- function(x, timename = "time") {
+  stopifnot("timename column missing or mispelled" = timename %in% names(x))
+  crs <- terra::crs(x)
+  output <- as.data.frame(x, geom = "XY") |>
+    data.table::as.data.table() |>
+    dt_as_mysftime("x", "y", timename, crs = crs)
+  return(output)
+}
+
 #' Convert to sftime object on the form adapted to beethoven code
 #'
 #' @param x a data.frame, data.table, SpatVector or SpatRasterDataset
 #' @param ... if x is a data.frame or data.table: lonname, latname, timename and
-#' crs arguments are recquired.
+#' crs arguments are required. If x is a sf or sftime, timename argument is
+#' required. If x is a terra::SpatRaster, varname argument is required.
+#' @return a sftime object with constrained time column name
+#' (see check_mysftime() function)
 #' @import sf
 #' @author Eva Marques
 #' @export
@@ -197,18 +342,24 @@ as_mysftime <- function(x, ...) {
   if (format == "data.frame") {
     output <- x |>
       data.table::data.table() |>
-      dt_to_mysftime(...)
+      dt_as_mysftime(...)
   } else if (format == "data.table") {
     output <- x |>
-      dt_to_mysftime(...)
+      dt_as_mysftime(...)
+  } else if (format == "sf") {
+    output <- x |>
+      sf_as_mysftime(...)
+  } else if (format == "sftime") {
+    output <- x |>
+      sftime_as_mysftime(...)
+  } else if (format == "SpatRaster") {
+    output <- x |>
+      spatraster_as_sftime(timename = "time", ...)
   } else if (format == "SpatVector") {
-    if (!("time" %in% names(x))) {
-      stop("x does not contain time column")
-    }
-    crs <- terra::crs(x)
-    output <- as.data.frame(x, geom = "XY") |>
-      data.table::as.data.table() |>
-      dt_to_mysftime("x", "y", "time", crs = crs)
+    output <- x |>
+      spatvector_as_sftime(...)
+    attributes(output)$time_column <- "time"
+    output <- dplyr::rename(output, "time" = ...)
   } else if (format == "SpatRasterDataset") {
     crs_dt <- terra::crs(x)
     stdf <- as.data.frame(x[1], xy = TRUE)
@@ -241,13 +392,50 @@ as_mysftime <- function(x, ...) {
       stdf[, varname_original] <- df_var[, 4]
     }
     output <- data.table::as.data.table(stdf) |>
-      dt_to_mysftime("lon", "lat", "time", crs_dt)
+      dt_as_mysftime("lon", "lat", "time", crs_dt)
   } else {
     stop("x class not accepted")
   }
   return(output)
 }
 
+#' Convert sftime object to SpatVector
+#'
+#' @param x a sftime
+#' @return a terra::SpatVector
+#' @import sftime
+#' @author Eva Marques
+#' @export
+sftime_as_spatvector <- function(x) {
+  stopifnot("x is not a sftime" = class(x)[1] == "sftime")
+  timecol <- attributes(x)$time_column
+  tosf <- x[, !(colnames(x) %in% c(timecol))]
+  tosf[, timecol] <- as.data.table(x)[, get(timecol)]
+  return(terra::vect(tosf))
+}
+
+#' Convert sftime object to SpatRaster
+#' /!\ can be very time consuming if sftime is not spatially structured
+#'
+#' @param x a sftime
+#' @param varname variable to rasterize
+#' @return a SpatRaster with layers corresponding to timestamps
+#' @import sftime
+#' @import stars
+#' @author Eva Marques
+#' @export
+sftime_as_spatraster <- function(x, varname) {
+  stopifnot("varname missing or mispelled" = varname %in% colnames(x))
+  dates <- unique(sftime::st_time(x))
+  layers <- list()
+  for (d in dates) {
+    newrast <- stars::st_rasterize(x[which(st_time(x) == d), varname]) |>
+      terra::rast()
+    layers[[d]] <- newrast
+  }
+  return(terra::rast(layers))
+}
+
 #' Convert a stdt to sf/sftime/SpatVector
 #' @param stdt A stdt object
 #' @param class_to character(1). Should be one of
@@ -362,7 +550,7 @@ convert_stdt_spatrastdataset <- function(stdt) {
 #' @author Eva Marques
 #' @importFrom sf st_as_sf
 #' @return an sf object
-dt_to_sf <- function(datatable, crs) {
+dt_as_sf <- function(datatable, crs) {
   if (!("data.table" %in% class(datatable))) {
     stop("datatable is not a data.table")
   }
@@ -394,7 +582,7 @@ dt_to_sf <- function(datatable, crs) {
 #' e.g., "2023-01-01", "01/01/2023", etc.
 #' @author Eva Marques
 #' @return an sftime object
-dt_to_sftime <- function(datatable, crs) {
+dt_as_sftime <- function(datatable, crs) {
   if (!("data.table" %in% class(datatable))) {
     stop("datatable is not a data.table")
   }
@@ -453,7 +641,7 @@ project_dt <- function(datatable, crs_ori, crs_dest) {
   }
 
   loc <- unique(datatable[, c("lon", "lat")])
-  loc_sf <- dt_to_sf(loc, crs_ori)
+  loc_sf <- dt_as_sf(loc, crs_ori)
   loc_sf <- sf::st_transform(loc_sf, crs_dest)
   colnames(loc_sf)[colnames(loc_sf) == "lon"] <- "lon_ori"
   colnames(loc_sf)[colnames(loc_sf) == "lat"] <- "lat_ori"