new function sits_get_class

DESCRIPTION

@@ -96,6 +96,7 @@ Suggests:
     mgcv,
     nnet,
     openxlsx,
+    proxy,
     randomForest,
     randomForestExplainer,
     RColorBrewer,
@@ -241,6 +242,7 @@ Collate:
     'sits_filters.R'
     'sits_geo_dist.R'
     'sits_get_data.R'
+    'sits_get_class.R'
     'sits_histogram.R'
     'sits_imputation.R'
     'sits_labels.R'

NAMESPACE

@@ -406,6 +406,12 @@ S3method(sits_cube,default)
 S3method(sits_cube,local_cube)
 S3method(sits_cube,sar_cube)
 S3method(sits_cube,stac_cube)
+S3method(sits_get_class,csv)
+S3method(sits_get_class,data.frame)
+S3method(sits_get_class,default)
+S3method(sits_get_class,sf)
+S3method(sits_get_class,shp)
+S3method(sits_get_class,sits)
 S3method(sits_get_data,csv)
 S3method(sits_get_data,data.frame)
 S3method(sits_get_data,default)
@@ -516,6 +522,7 @@ export(sits_filter)
 export(sits_formula_linear)
 export(sits_formula_logref)
 export(sits_geo_dist)
+export(sits_get_class)
 export(sits_get_data)
 export(sits_impute)
 export(sits_kfold_validate)

R/api_csv.R

@@ -31,7 +31,8 @@
     return(samples)
 }
 
-#' @title Transform a CSV with labelled points for accuracy assessmentinto a samples file
+#' @title Transform a CSV with labelled points for accuracy assessment
+#'        into a samples file
 #' @name .csv_get_validation_samples
 #' @author Gilberto Camara
 #' @keywords internal
@@ -57,3 +58,26 @@
     class(samples) <- c("sits", class(samples))
     return(samples)
 }
+#' @title Transform a CSV with lat/long into samples
+#' @name .csv_get_class_samples
+#' @author Gilberto Camara
+#' @keywords internal
+#' @noRd
+#' @param csv_file        CSV that describes the data to be retrieved.
+#' @return                A tibble with information the samples to be retrieved
+#'
+.csv_get_class_samples <- function(csv_file) {
+    # read sample information from CSV file and put it in a tibble
+    samples <- tibble::as_tibble(
+        utils::read.csv(
+            file = csv_file,
+            stringsAsFactors = FALSE
+        )
+    )
+    # select valid columns
+    samples <- dplyr::select(
+        samples,
+        c("longitude", "latitude")
+    )
+    return(samples)
+}

R/api_data.R

@@ -837,3 +837,60 @@
     })
 }
 
+#' @title function to get class for point in a classified cube
+#' @name .data_get_class
+#' @author Gilberto Camara
+#' @keywords internal
+#' @noRd
+#' @param cube            Classified data cube from where data is to be retrieved.
+#' @param samples         Samples to be retrieved.
+#'
+#' @return                A tibble with a list of lat/long and respective classes.
+#'
+.data_get_class <- function(cube, samples){
+    data <- slider::slide_dfr(cube, function(tile) {
+        # convvert lat/long to tile CRS
+        xy_tb <- .proj_from_latlong(
+            longitude = samples[["longitude"]],
+            latitude  = samples[["latitude"]],
+            crs       = .cube_crs(tile)
+        )
+        # join lat-long with XY values in a single tibble
+        samples <- dplyr::bind_cols(samples, xy_tb)
+        # filter the points inside the data cube space-time extent
+        samples <- dplyr::filter(
+            samples,
+            .data[["X"]] > tile[["xmin"]],
+            .data[["X"]] < tile[["xmax"]],
+            .data[["Y"]] > tile[["ymin"]],
+            .data[["Y"]] < tile[["ymax"]]
+        )
+
+        # are there points to be retrieved from the cube?
+        if (nrow(samples) == 0) {
+            return(NULL)
+        }
+        # create a matrix to extract the values
+        xy <- matrix(
+            c(samples[["X"]], samples[["Y"]]),
+            nrow = nrow(samples),
+            ncol = 2
+        )
+        colnames(xy) <- c("X", "Y")
+
+        # open spatial raster object
+        rast <- .raster_open_rast(.tile_path(tile))
+
+        # get cells from XY coords
+        class_numbers <- dplyr::pull(.raster_extract(rast, xy))
+        # convert class numbers in labels
+        labels <- .cube_labels(tile)
+        classes <- labels[class_numbers]
+        # insert classes into samples
+        samples[["label"]] <- unname(classes)
+        samples <- dplyr::select(samples, .data[["longitude"]],
+                                 .data[["latitude"]], .data[["label"]])
+        return(samples)
+    })
+    return(data)
+}

R/api_sf.R

@@ -112,6 +112,7 @@
 }
 
 #' @title Obtain a tibble with latitude/longitude points from POINT geometry
+#'        including labels
 #' @name .sf_point_to_tibble
 #' @keywords internal
 #' @noRd
@@ -148,7 +149,27 @@
 
     return(points_tbl)
 }
+#' @title Obtain a tibble with latitude/longitude points from POINT geometry
+#' @name .sf_point_to_latlong
+#' @keywords internal
+#' @noRd
+#' @param sf_object       sf object
+#' @return  A tibble with latitude/longitude points.
+#'
+.sf_point_to_latlong <- function(sf_object) {
+    # get the db file
+    sf_df <- sf::st_drop_geometry(sf_object)
 
+    # if geom_type is POINT, use the points provided in the shapefile
+    points <- sf::st_coordinates(sf_object)
+
+    # build a tibble with lat/long and label
+    points_tbl <- tibble::tibble(
+        longitude = points[, 1],
+        latitude = points[, 2],
+    )
+    return(points_tbl)
+}
 #' @title Obtain a tibble from POLYGON geometry
 #' @name .sf_polygon_to_tibble
 #' @keywords internal

R/api_som.R

@@ -176,10 +176,10 @@
 #' @param som_map        kohonen_map
 #' @return               adjacency matrix with the distances btw neurons.
 #'
-# .som_adjacency <- function(som_map) {
-#     koh <- som_map$som_properties
-#     adjacency <- proxy::as.matrix(proxy::dist(koh$codes$NDVI, method = "dtw"))
-# }
+.som_adjacency <- function(som_map) {
+    koh <- som_map$som_properties
+    adjacency <- proxy::as.matrix(proxy::dist(koh$codes$NDVI, method = "dtw"))
+}
 
 #' @title Transform SOM map into sf object.
 #' @name .som_to_sf

R/sits_get_class.R

@@ -0,0 +1,113 @@
+#' @title Get values from classified maps
+#' @name sits_get_class
+#' @author Gilberto Camara
+#'
+#' @description Given a set of lat/long locations and a classified cube,
+#' retrieve the class of each point.
+#' @note
+#' There are four ways of specifying data to be retrieved using the
+#' \code{samples} parameter:
+#' (a) CSV file: a CSV file with columns \code{longitude}, \code{latitude};
+#' (b) SHP file: a shapefile in POINT geometry;
+#' (c) sits object: A sits tibble;
+#' (d) sf object: An \code{link[sf]{sf}} object with POINT or geometry;
+#' (e) data.frame: A data.frame with \code{longitude} and \code{latitude}.
+#'
+#'
+#' @param cube            Classified data cube from where data is to be retrieved.
+#'                        (class "class_cube").
+#' @param samples         Location of the samples to be retrieved.
+#'                        Either a tibble of class "sits", an "sf" object,
+#'                        the name of a shapefile or csv file, or
+#'                        a data.frame with columns "longitude" and "latitude"
+#' @return                A tibble of with columns
+#'                        <longitude, latitude, start_date, end_date, label>.
+#' @export
+sits_get_class <- function(cube, samples){
+    .check_set_caller("sits_get_data")
+    # Pre-conditions
+    .check_is_class_cube(cube)
+    .check_raster_cube_files(cube)
+    if (is.character(samples)) {
+        class(samples) <- c(.file_ext(samples), class(samples))
+    }
+    UseMethod("sits_get_class", samples)
+}
+#' @rdname sits_get_class
+#'
+#' @export
+sits_get_class.default <- function(cube, samples){
+    stop(.conf("messages", "sits_get_class_default"))
+}
+#' @rdname sits_get_class
+#'
+#' @export
+sits_get_class.csv <- function(cube, samples){
+    # Extract a data frame from csv
+    samples <- .csv_get_class_samples(samples)
+    data <- .data_get_class(
+        cube       = cube,
+        samples    = samples
+    )
+    return(data)
+}
+#' @rdname sits_get_class
+#' @export
+sits_get_class.shp <- function(cube, samples){
+    .check_set_caller("sits_get_data")
+    # transform from shapefile to sf
+    sf_shape <- .shp_transform_to_sf(shp_file = samples)
+    # Get the geometry type
+    geom_type <- as.character(sf::st_geometry_type(sf_shape)[[1]])
+    if (!geom_type == "POINT")
+        stop(.conf("messages", "sits_get_class_not_point"))
+
+    # Get a tibble with points
+    samples <- .sf_point_to_latlong(sf_object  = sf_shape)
+    # get the data
+    data <- .data_get_class(
+        cube       = cube,
+        samples    = samples
+    )
+    return(data)
+}
+#' @rdname sits_get_class
+#' @export
+sits_get_class.sf <- function(cube, samples){
+    .check_set_caller("sits_get_data")
+    # Get the geometry type
+    geom_type <- as.character(sf::st_geometry_type(samples)[[1]])
+    if (!geom_type == "POINT")
+        stop(.conf("messages", "sits_get_class_not_point"))
+
+    # Get a tibble with points
+    samples <- .sf_point_to_latlong(sf_object  = samples)
+    # get the data
+    data <- .data_get_class(
+        cube       = cube,
+        samples    = samples
+    )
+    return(data)
+}
+#' @rdname sits_get_class
+#' @export
+sits_get_class.sits <- function(cube, samples){
+    .check_set_caller("sits_get_data")
+    # get the data
+    data <- .data_get_class(
+        cube       = cube,
+        samples    = samples
+    )
+    return(data)
+}
+#' @rdname sits_get_class
+#' @export
+sits_get_class.data.frame <- function(cube, samples){
+    .check_set_caller("sits_get_data")
+    # get the data
+    data <- .data_get_class(
+        cube       = cube,
+        samples    = samples
+    )
+    return(data)
+}

R/sits_get_data.R

@@ -55,7 +55,7 @@
 #' @param progress        Logical: show progress bar?
 #'
 #' @return A tibble of class "sits" with set of time series
-#' <longitude, latitude, start_date, end_date, label, cube, time_series>.
+#' <longitude, latitude, start_date, end_date, label>.
 #'
 #'
 #' @examples

inst/extdata/config_messages.yml

@@ -373,6 +373,9 @@ sits_dtw: "wrong input parameters - see example in documentation"
 sits_filter: "input should be a valid set of training samples or a non-classified data cube"
 sits_formula_linear: "invalid input data"
 sits_formula_logref: "invalid input data"
+sits_get_class: "unable to retrieve data from classified cube - check input parameters"
+sits_get_class_default: "invalid samples - check documentation"
+sits_get_class_not_point: "samples should have POINT geometry type"
 sits_get_data: "unable to retrieve data - check input parameters"
 sits_get_data_default: "invalid samples - check documentation"
 sits_get_data_data_frame: "missing lat/long information in data frame"