From 79355e0332280131f743a8c06374c0e9f3a13521 Mon Sep 17 00:00:00 2001 From: Gilberto Camara Date: Wed, 6 Dec 2023 15:58:07 -0300 Subject: [PATCH] include uncertainty plot --- NAMESPACE | 2 + R/api_plot_raster.R | 4 +- R/api_plot_vector.R | 57 +++++++++++++++++ R/sits_bands.R | 14 +++++ R/sits_plot.R | 95 +++++++++++++++++++++++++++++ R/sits_segmentation.R | 2 +- inst/extdata/config_internals.yml | 2 +- man/plot.uncertainty_vector_cube.Rd | 85 ++++++++++++++++++++++++++ man/sits_bands.Rd | 3 + 9 files changed, 260 insertions(+), 4 deletions(-) create mode 100644 man/plot.uncertainty_vector_cube.Rd diff --git a/NAMESPACE b/NAMESPACE index 32b557e76..deb9ca418 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -257,6 +257,7 @@ S3method(plot,som_evaluate_cluster) S3method(plot,som_map) S3method(plot,torch_model) S3method(plot,uncertainty_cube) +S3method(plot,uncertainty_vector_cube) S3method(plot,variance_cube) S3method(plot,vector_cube) S3method(plot,xgb_model) @@ -281,6 +282,7 @@ S3method(sits_bands,raster_cube) S3method(sits_bands,sits) S3method(sits_bands,sits_model) S3method(sits_bands,tbl_df) +S3method(sits_bands,vector_cube) S3method(sits_bbox,default) S3method(sits_bbox,raster_cube) S3method(sits_bbox,sits) diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R index 95f4c272c..4e11874b3 100644 --- a/R/api_plot_raster.R +++ b/R/api_plot_raster.R @@ -483,7 +483,7 @@ #' .plot_tmap_params <- function(tmap_user) { # reset the tmap params - tmap::tmap_options_reset() + suppressMessages(tmap::tmap_options_reset()) # get the tmap defaults tmap_options <- list( graticules_labels_size = @@ -508,7 +508,7 @@ keys, collapse = " ") ) for (k in names(tmap_user)) - tmap_options <- tmap_user[[k]] + tmap_options[[k]] <- tmap_user[[k]] } # set tmap options tmap::tmap_options(scale = as.numeric(tmap_options[["scale"]]), diff --git a/R/api_plot_vector.R b/R/api_plot_vector.R index 2c4f0d00c..928f7f259 100644 --- a/R/api_plot_vector.R +++ b/R/api_plot_vector.R @@ -151,3 +151,60 @@ return(suppressWarnings(p)) } +#' @title Plot uncertainty vector cube +#' @name .plot_uncertainty_vector +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @description plots an uncertainty vector cube +#' @keywords internal +#' @noRd +#' @param tile Tile to be plotted. +#' @param palette A sequential RColorBrewer palette +#' @param rev Revert the color of the palette? +#' @param tmap_options Named vector with optional tmap parameters +#' +#' @return A plot object +#' +.plot_uncertainty_vector <- function(tile, + palette, + rev, + tmap_options) { + # verifies if stars package is installed + .check_require_packages("stars") + # verifies if tmap package is installed + .check_require_packages("tmap") + # precondition - check color palette + .check_palette(palette) + # revert the palette + if (rev) { + palette <- paste0("-", palette) + } + # get the segements to be plotted + sf_seg <- .segments_read_vec(tile) + # set the tmap options + tmap_options <- .plot_tmap_params(tmap_options) + # obtain the uncertainty type + uncert_type <- .vi(tile)$band + # plot the segments by facet + p <- tmap::tm_shape(sf_seg) + + tmap::tm_polygons(uncert_type, palette = palette) + + tmap::tm_graticules( + labels.size = tmap_options[["graticules_labels_size"]] + ) + + tmap::tm_compass() + + tmap::tm_layout( + fontfamily = tmap_options[["font_family"]], + legend.bg.color = tmap_options[["legend_bg_color"]], + legend.bg.alpha = tmap_options[["legend_bg_alpha"]], + legend.title.size = tmap_options[["legend_title_size"]], + legend.text.size = tmap_options[["legend_text_size"]], + legend.width = tmap_options[["legend_width"]], + legend.height = tmap_options[["legend_height"]], + outer.margins = c(0.00001, 0.00001, 0.00001, 0.00001), + inner.margins = c(0, 0, 0, 0), + between.margin = 0, + asp = 0 + ) + + tmap::tm_borders(lwd = 0.2) + + return(suppressWarnings(p)) +} diff --git a/R/sits_bands.R b/R/sits_bands.R index 826ef8e63..b63dbfc56 100644 --- a/R/sits_bands.R +++ b/R/sits_bands.R @@ -63,6 +63,20 @@ sits_bands.raster_cube <- function(x) { } #' @rdname sits_bands #' @export +sits_bands.vector_cube <- function(x) { + bands_lst <- slider::slide(x, function(tile) { + bands_tile <- .vi(tile)$band + return(bands_tile) + }) + bands <- unique(bands_lst) + .check_that(length(bands) == 1, + local_msg = "tiles have different bands", + msg = "cube is inconsistent" + ) + return(unlist(bands)) +} +#' @rdname sits_bands +#' @export sits_bands.patterns <- function(x) { return(sits_bands.sits(x)) } diff --git a/R/sits_plot.R b/R/sits_plot.R index 755679de5..ec450b677 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -905,6 +905,101 @@ plot.uncertainty_cube <- function(x, ..., return(p) } +#' @title Plot uncertainty vector cubes +#' @name plot.uncertainty_vector_cube +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @description plots a probability cube using stars +#' +#' @param x Object of class "probs_vector_cube". +#' @param ... Further specifications for \link{plot}. +#' @param tile Tile to be plotted. +#' @param palette RColorBrewer palette +#' @param rev Reverse order of colors in palette? +#' @param tmap_options Named list with optional tmap parameters +#' max_cells (default: 1e+06) +#' scale (default: 1.0) +#' graticules_labels_size (default: 0.7) +#' legend_title_size (default: 1.0) +#' legend_text_size (default: 1.0) +#' legend_bg_color (default: "white") +#' legend_bg_alpha (default: 0.5) +#' @return A plot containing probabilities associated +#' to each class for each pixel. +#' +#' +#' @examples +#' if (sits_run_examples()) { +#' # create a random forest model +#' rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) +#' # create a data cube from local files +#' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") +#' cube <- sits_cube( +#' source = "BDC", +#' collection = "MOD13Q1-6", +#' data_dir = data_dir +#' ) +#' # segment the image +#' segments <- sits_segment( +#' cube = cube, +#' seg_fn = sits_slic(step = 5, +#' compactness = 1, +#' dist_fun = "euclidean", +#' avg_fun = "median", +#' iter = 20, +#' minarea = 10, +#' verbose = FALSE), +#' output_dir = tempdir() +#' ) +#' # classify a data cube +#' probs_vector_cube <- sits_classify( +#' data = segments, +#' ml_model = rfor_model, +#' output_dir = tempdir() +#' ) +#' # measure uncertainty +#' uncert_vector_cube <- sits_uncertainty( +#' cube = probs_vector_cube, +#' type = "margin", +#' output_dir = tempdir() +#' ) +#' # plot the resulting uncertainty cube +#' plot(uncert_vector_cube) +#' } +#' +#' @export +#' +plot.uncertainty_vector_cube <- function(x, ..., + tile = x$tile[[1]], + palette = "RdYlGn", + rev = FALSE, + tmap_options = NULL) { + # check for color_palette parameter (sits 1.4.1) + dots <- list(...) + if (missing(palette) && "color_palette" %in% names(dots)) { + warning("please use palette in place of color_palette") + palette <- dots[["color_palette"]] + } + # precondition + .check_chr_contains( + x = x$tile, + contains = tile, + case_sensitive = FALSE, + discriminator = "one_of", + can_repeat = FALSE, + msg = "tile is not included in the cube" + ) + + # filter the cube + tile <- .cube_filter_tiles(cube = x, tiles = tile) + + # plot the probs vector cube + p <- .plot_uncertainty_vector(tile = tile, + palette = palette, + rev = rev, + tmap_options = tmap_options) + + return(p) +} #' @title Plot classified images #' @name plot.class_cube #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} diff --git a/R/sits_segmentation.R b/R/sits_segmentation.R index ac4bb29b8..07081ec83 100644 --- a/R/sits_segmentation.R +++ b/R/sits_segmentation.R @@ -240,7 +240,7 @@ sits_slic <- function(data = NULL, # step is OK? .check_int_parameter(step, min = 1, max = 500) # compactness is OK? - .check_int_parameter(compactness, min = 1, max = 50) + .check_num_parameter(compactness, min = 0.1, max = 50) # iter is OK? .check_int_parameter(iter, min = 10, max = 100) # minarea is OK? diff --git a/inst/extdata/config_internals.yml b/inst/extdata/config_internals.yml index 2c3683299..9e8652b94 100644 --- a/inst/extdata/config_internals.yml +++ b/inst/extdata/config_internals.yml @@ -250,7 +250,7 @@ tmap: legend_width: 1.0 legend_position: ["left", "bottom"] legend_height: 1.0 - scale: 1.5 + scale: 1.0 font_family: "plex_sans" # maxbytes for leaflet (in MB) diff --git a/man/plot.uncertainty_vector_cube.Rd b/man/plot.uncertainty_vector_cube.Rd new file mode 100644 index 000000000..ebcd6283e --- /dev/null +++ b/man/plot.uncertainty_vector_cube.Rd @@ -0,0 +1,85 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_plot.R +\name{plot.uncertainty_vector_cube} +\alias{plot.uncertainty_vector_cube} +\title{Plot uncertainty vector cubes} +\usage{ +\method{plot}{uncertainty_vector_cube}( + x, + ..., + tile = x$tile[[1]], + palette = "RdYlGn", + rev = FALSE, + tmap_options = NULL +) +} +\arguments{ +\item{x}{Object of class "probs_vector_cube".} + +\item{...}{Further specifications for \link{plot}.} + +\item{tile}{Tile to be plotted.} + +\item{palette}{RColorBrewer palette} + +\item{rev}{Reverse order of colors in palette?} + +\item{tmap_options}{Named list with optional tmap parameters +max_cells (default: 1e+06) +scale (default: 1.0) +graticules_labels_size (default: 0.7) +legend_title_size (default: 1.0) +legend_text_size (default: 1.0) +legend_bg_color (default: "white") +legend_bg_alpha (default: 0.5)} +} +\value{ +A plot containing probabilities associated + to each class for each pixel. +} +\description{ +plots a probability cube using stars +} +\examples{ +if (sits_run_examples()) { + # create a random forest model + rfor_model <- sits_train(samples_modis_ndvi, sits_rfor()) + # create a data cube from local files + data_dir <- system.file("extdata/raster/mod13q1", package = "sits") + cube <- sits_cube( + source = "BDC", + collection = "MOD13Q1-6", + data_dir = data_dir + ) + # segment the image + segments <- sits_segment( + cube = cube, + seg_fn = sits_slic(step = 5, + compactness = 1, + dist_fun = "euclidean", + avg_fun = "median", + iter = 20, + minarea = 10, + verbose = FALSE), + output_dir = tempdir() + ) + # classify a data cube + probs_vector_cube <- sits_classify( + data = segments, + ml_model = rfor_model, + output_dir = tempdir() + ) + # measure uncertainty + uncert_vector_cube <- sits_uncertainty( + cube = probs_vector_cube, + type = "margin", + output_dir = tempdir() + ) + # plot the resulting uncertainty cube + plot(uncert_vector_cube) +} + +} +\author{ +Gilberto Camara, \email{gilberto.camara@inpe.br} +} diff --git a/man/sits_bands.Rd b/man/sits_bands.Rd index da014095b..33ceb3c71 100644 --- a/man/sits_bands.Rd +++ b/man/sits_bands.Rd @@ -4,6 +4,7 @@ \alias{sits_bands} \alias{sits_bands.sits} \alias{sits_bands.raster_cube} +\alias{sits_bands.vector_cube} \alias{sits_bands.patterns} \alias{sits_bands.sits_model} \alias{sits_bands.tbl_df} @@ -20,6 +21,8 @@ sits_bands(x) \method{sits_bands}{raster_cube}(x) +\method{sits_bands}{vector_cube}(x) + \method{sits_bands}{patterns}(x) \method{sits_bands}{sits_model}(x)