diff --git a/.gitignore b/.gitignore index dfac82a58..6f8f0a13b 100644 --- a/.gitignore +++ b/.gitignore @@ -21,6 +21,7 @@ inst/doc doc Meta *.bkp +*.pdf .sits/ *.gcda *.gcno diff --git a/DESCRIPTION b/DESCRIPTION index c0ec9bee6..aad75772b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: sits Type: Package -Version: 1.4.2-2 +Version: 1.4.2-3 Title: Satellite Image Time Series Analysis for Earth Observation Data Cubes Authors@R: c(person('Rolf', 'Simoes', role = c('aut'), email = 'rolf.simoes@inpe.br'), person('Gilberto', 'Camara', role = c('aut', 'cre'), email = 'gilberto.camara.inpe@gmail.com'), @@ -91,6 +91,7 @@ Suggests: randomForestExplainer, RcppArmadillo (>= 0.12), scales, + spdep, stars (>= 0.6), stringr, supercells, @@ -203,6 +204,7 @@ Collate: 'sits_csv.R' 'sits_cube.R' 'sits_cube_copy.R' + 'sits_clean.R' 'sits_cluster.R' 'sits_factory.R' 'sits_filters.R' diff --git a/NAMESPACE b/NAMESPACE index 4d2426f05..655615c8d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -237,6 +237,7 @@ S3method(.tile_yres,raster_cube) S3method(.values_ts,bands_cases_dates) S3method(.values_ts,bands_dates_cases) S3method(.values_ts,cases_dates_bands) +S3method(.view_add_overlay_grps,class_cube) S3method(.view_add_overlay_grps,derived_cube) S3method(.view_add_overlay_grps,raster_cube) S3method(.view_add_overlay_grps,vector_cube) @@ -256,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) @@ -290,6 +292,11 @@ S3method(sits_classify,raster_cube) S3method(sits_classify,segs_cube) S3method(sits_classify,sits) S3method(sits_classify,tbl_df) +S3method(sits_clean,class_cube) +S3method(sits_clean,default) +S3method(sits_clean,derived_cube) +S3method(sits_clean,raster_cube) +S3method(sits_clean,tbl_df) S3method(sits_cluster_dendro,default) S3method(sits_cluster_dendro,sits) S3method(sits_cluster_dendro,tbl_df) @@ -356,10 +363,11 @@ S3method(sits_timeline,tbl_df) S3method(sits_to_csv,default) S3method(sits_to_csv,sits) S3method(sits_to_csv,tbl_df) +S3method(sits_to_xlsx,list) +S3method(sits_to_xlsx,sits_accuracy) S3method(sits_uncertainty,default) -S3method(sits_uncertainty,entropy) -S3method(sits_uncertainty,least) -S3method(sits_uncertainty,margin) +S3method(sits_uncertainty,probs_cube) +S3method(sits_uncertainty,probs_vector_cube) S3method(sits_variance,default) S3method(sits_variance,derived_cube) S3method(sits_variance,probs_cube) @@ -389,6 +397,7 @@ export(sits_as_sf) export(sits_bands) export(sits_bbox) export(sits_classify) +export(sits_clean) export(sits_cluster_clean) export(sits_cluster_dendro) export(sits_cluster_frequency) @@ -434,6 +443,7 @@ export(sits_rfor) export(sits_run_examples) export(sits_run_tests) export(sits_sample) +export(sits_sampling_design) export(sits_segment) export(sits_select) export(sits_sgolay) diff --git a/NEWS.md b/NEWS.md index 0d48b653e..28d25ec79 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,9 @@ # What's new in SITS version 1.4 +### Hotfix version 1.4.2-3 +* Fix font download in package initialization + ### Hotfix version 1.4.2-2 * Fix integer overflow bug in `sits_classify()` segments diff --git a/R/api_check.R b/R/api_check.R index 0f267471a..6a28feb76 100644 --- a/R/api_check.R +++ b/R/api_check.R @@ -255,7 +255,7 @@ #' @rdname check_functions #' @keywords internal #' @noRd -.check_cube_files <- function(x, ...) { +.check_raster_cube_files <- function(x, ...) { # check for data access robj <- tryCatch( .raster_open_rast(.tile_path(x)), @@ -1105,16 +1105,18 @@ #' @param max maximum value #' @param len_min minimum length of vector #' @param len_max maximum length of vector +#' @param allow_null Allow NULL value? #' @param msg Error message #' @return Called for side effects. #' @keywords internal #' @noRd .check_int_parameter <- function(param, min = 1, max = 2^31 - 1, - len_min = 1, len_max = 1, msg = NULL) { + len_min = 1, len_max = 1, + allow_null = FALSE, msg = NULL) { .check_num( x = param, allow_na = FALSE, - allow_null = FALSE, + allow_null = allow_null, min = min, max = max, len_min = len_min, diff --git a/R/api_classify.R b/R/api_classify.R index eb5305046..b3f523622 100755 --- a/R/api_classify.R +++ b/R/api_classify.R @@ -266,7 +266,7 @@ progress = FALSE ) # Classify segments - classified_ts <- .classify_ts( + segments_ts <- .classify_ts( samples = segments_ts, ml_model = ml_model, filter_fn = filter_fn, @@ -275,13 +275,13 @@ progress = progress ) # Join probability values with segments - joined_segments <- .segments_join_probs( - data = classified_ts, - segments = .segments_read_vec(tile), - aggregate = .has(n_sam_pol) + segments_ts <- .segments_join_probs( + data = segments_ts, + segments = .segments_read_vec(tile) ) + # Write all segments - .vector_write_vec(v_obj = joined_segments, file_path = out_file) + .vector_write_vec(v_obj = segments_ts, file_path = out_file) # Create tile based on template probs_tile <- .tile_segments_from_file( file = out_file, diff --git a/R/api_clean.R b/R/api_clean.R index d69bc6fea..d1a519649 100644 --- a/R/api_clean.R +++ b/R/api_clean.R @@ -7,7 +7,7 @@ #' the most frequently values within the neighborhood. #' In a tie, the first value of the vector is considered. #' -#' @param asset Subset of a data cube +#' @param tile Subset of a data cube #' @param block Image block to be cleaned #' @param band Band to be processed #' @param window_size Size of local neighborhood @@ -26,6 +26,19 @@ out_file <- .file_derived_name( tile = tile, band = band, version = version, output_dir = output_dir ) + # Resume tile + if (.raster_is_valid(out_file, output_dir = output_dir)) { + # recovery message + .check_recovery(out_file) + # Create tile based on template + tile <- .tile_derived_from_file( + file = out_file, band = band, + base_tile = tile, derived_class = .tile_derived_class(tile), + labels = .tile_labels(tile), + update_bbox = FALSE + ) + return(tile) + } # Create chunks as jobs chunks <- .tile_chunks_create( tile = tile, overlap = overlap, block = block @@ -86,8 +99,9 @@ update_bbox = FALSE ) # Return a asset - band_tile + return(band_tile) } + #' @title Read data for cleaning operation #' @name .clean_data_read #' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} @@ -103,5 +117,5 @@ # Set columns name colnames(values) <- band # Return values - values + return(values) } diff --git a/R/api_conf.R b/R/api_conf.R index 937c249ae..6ef793afc 100644 --- a/R/api_conf.R +++ b/R/api_conf.R @@ -176,7 +176,7 @@ return(yml_file) } -#' @title Get color table +#' @title Loads default color table and legends #' @name .conf_load_color_table #' @description Loads the default color table #' @keywords internal @@ -189,11 +189,12 @@ input = color_yml_file, merge.precedence = "override" ) - class_schemes <- config_colors$class_schemes - sits_env[["config"]] <- utils::modifyList(sits_env[["config"]], - class_schemes, - keep.null = FALSE - ) + # set the legends + sits_env$legends <- config_colors$legends + # sits_env[["config"]] <- utils::modifyList(sits_env[["config"]], + # class_schemes, + # keep.null = FALSE + # ) colors <- config_colors$colors color_table <- purrr::map2_dfr(colors, names(colors), function(cl, nm) { @@ -203,17 +204,18 @@ ) return(cc_tb) }) + # set the color table - .conf_set_color_table(color_table) + sits_env$color_table <- color_table return(invisible(color_table)) } -#' @title Set user color table -#' @name .conf_set_color_table +#' @title Add user color table +#' @name .conf_add_color_table #' @description Loads a user color table #' @keywords internal #' @noRd -#' @return Called for side effects -.conf_set_color_table <- function(color_tb) { +#' @return new color table (invisible) +.conf_add_color_table <- function(color_tb) { # pre condition - table contains name and hex code .check_chr_contains( x = colnames(color_tb), @@ -221,20 +223,20 @@ discriminator = "all_of", msg = "invalid colour table - missing either name or hex columns" ) - # pre condition - table contains no duplicates - tbd <- dplyr::distinct(color_tb, .data[["name"]]) - .check_that(nrow(tbd) == nrow(color_tb), - msg = "color table contains duplicate names" - ) - sits_env$color_table <- color_tb - return(invisible(color_tb)) + # replace all duplicates + new_colors <- dplyr::pull(color_tb, .data[["name"]]) + # remove duplicate colors + old_color_tb <- dplyr::filter(sits_env$color_table, + !(.data[["name"]] %in% new_colors)) + sits_env$color_table <- dplyr::bind_rows(old_color_tb, color_tb) + return(invisible(sits_env$color_table)) } #' @title Merge user colors with default colors #' @name .conf_merge_colors #' @description Combines user colors with default color table #' @keywords internal #' @noRd -#' @return NULL, called for side effects +#' @return new color table .conf_merge_colors <- function(user_colors) { # get the current color table color_table <- .conf_colors() @@ -253,8 +255,25 @@ ) } } - .conf_set_color_table(color_table) - return(invisible(color_table)) + sits_env$color_table <- color_table + return(color_table) +} +.conf_merge_legends <- function(user_legends){ + # check legends are valid names + .check_chr_parameter(names(user_legends), len_max = 100, + msg = "invalid user legends") + # check legend names do not already exist + .check_that(!(all(names(user_legends) %in% names (sits_env$legends))), + msg = "user defined legends already exist in sits") + # check colors names are valid + ok <- purrr::map_lgl(user_legends, function(leg){ + .check_chr_parameter(leg, len_max = 100, + msg = "invalid color names in user legend") + return(TRUE) + }) + sits_env$legends <- c(sits_env$legends, user_legends) + return(invisible(sits_env$legends)) + } #' @title Return the default color table #' @name .conf_colors @@ -343,14 +362,10 @@ .conf_merge_colors(user_colors) user_config$colors <- NULL } - if (!purrr::is_null(user_config$class_schemes)) { - class_schemes <- user_config$class_schemes - sits_env[["config"]] <- utils::modifyList( - sits_env[["config"]], - class_schemes, - keep.null = FALSE - ) - user_config$class_schemes <- NULL + if (!purrr::is_null(user_config$legends)) { + user_legends <- user_config$legends + .conf_merge_legends(user_legends) + user_config$legends <- NULL } if (length(user_config) > 0) { user_config <- utils::modifyList(sits_env[["config"]], diff --git a/R/api_cube.R b/R/api_cube.R index 1d662d35f..adcd3ceb5 100644 --- a/R/api_cube.R +++ b/R/api_cube.R @@ -132,6 +132,48 @@ NULL # return the cube x } +#' @title Return areas of classes of a class_cue +#' @keywords internal +#' @noRd +#' @name .cube_class_areas +#' @param cube class cube +#' +#' @return A \code{vector} with the areas of the cube labels. +.cube_class_areas <- function(cube) { + .check_cube_is_class_cube(cube) + labels_cube <- sits_labels(cube) + + # Get area for each class for each row of the cube + freq_lst <- slider::slide(cube, function(tile) { + # Get the frequency count and value for each labelled image + freq <- .tile_area_freq(tile) + # pixel area + # convert the area to hectares + # assumption: spatial resolution unit is meters + area <- freq$count * .tile_xres(tile) * .tile_yres(tile) / 10000 + # Include class names + freq <- dplyr::mutate(freq, + area = area, + class = labels_cube[.as_chr(freq$value)] + ) + return(freq) + }) + # Get a tibble by binding the row (duplicated labels with different counts) + freq <- do.call(rbind, freq_lst) + # summarize the counts for each label + freq <- freq |> + dplyr::filter(!is.na(class)) |> + dplyr::group_by(class) |> + dplyr::summarise(area = sum(.data[["area"]])) + + # Area is taken as the sum of pixels + class_areas <- freq$area + # Names of area are the classes + names(class_areas) <- freq$class + # NAs are set to 0 + class_areas[is.na(class_areas)] <- 0 + return(class_areas) +} #' @title Return bands of a data cube #' @keywords internal diff --git a/R/api_label_class.R b/R/api_label_class.R index 8b18e3fc3..3b212f09e 100644 --- a/R/api_label_class.R +++ b/R/api_label_class.R @@ -12,6 +12,19 @@ out_file <- .file_derived_name( tile = tile, band = band, version = version, output_dir = output_dir ) + # Resume feature + if (file.exists(out_file)) { + .check_recovery(tile[["tile"]]) + class_tile <- .tile_derived_from_file( + file = out_file, + band = "class", + base_tile = tile, + derived_class = "class_cube", + labels = .tile_labels(tile), + update_bbox = FALSE + ) + return(class_tile) + } # Create chunks as jobs chunks <- .tile_chunks_create(tile = tile, overlap = 0) # Process jobs in parallel diff --git a/R/api_plot_raster.R b/R/api_plot_raster.R index 5ee308569..cf1f784de 100644 --- a/R/api_plot_raster.R +++ b/R/api_plot_raster.R @@ -12,13 +12,14 @@ #' @param line_width Line width to plot the segments boundary #' @param palette A sequential RColorBrewer palette #' @param rev Reverse the color palette? -#' @param tmap_options List with optional tmap parameters -#' tmap max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) +#' @param tmap_options Named vector with optional tmap parameters: +#' scale (default = 1.0) +#' max_cells (default: 1e+06) +#' graticules_labels_size (default: 0.7) +#' legend_title_size (default: 1.5) +#' legend_text_size (default: 1.2) +#' legend_bg_color (default: "white") +#' legend_bg_alpha (default: 0.5) #' #' @return A plot object #' @@ -104,10 +105,10 @@ #' @param tile Tile to be plotted. #' @param legend Legend for the classes #' @param palette A sequential RColorBrewer palette -#' @param tmap_options List with optional tmap parameters +#' @param tmap_options Named vector with optional tmap parameters #' max_cells (default: 1e+06) #' scale (default: 0.8) -#' font_family (default: "plex_sans") +#' font_family (default: "sans") #' graticules_labels_size (default: 0.7) #' legend_title_size (default: 0.8) #' legend_text_size (default: 0.8) @@ -176,14 +177,99 @@ legend.bg.alpha = tmap_params[["legend_bg_alpha"]], legend.title.size = tmap_params[["legend_title_size"]], legend.text.size = tmap_params[["legend_text_size"]], - legend.width = tmap_params[["legend_width"]], - legend.height = tmap_params[["legend_height"]], - legend.position = tmap_params[["legend_position"]] + legend.width = tmap_params[["legend_width"]] + # legend.height = tmap_params[["legend_height"]], + # legend.position = tmap_params[["legend_position"]] ) ) return(p) } +#' @title Plot a RGB image +#' @name .plot_rgb +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' @keywords internal +#' @noRd +#' @param tile Tile to be plotted +#' @param red Band to be plotted in red +#' @param green Band to be plotted in green +#' @param blue Band to be plotted in blue +#' @param date Date to be plotted +#' @param sf_seg Segments (sf object) +#' @param seg_color Color to use for segment borders +#' @param line_width Line width to plot the segments boundary +#' @param tmap_options Named vector with optional tmap parameters +#' max_cells (default: 1e+06) +#' graticules_labels_size (default: 0.7) +#' legend_title_size (default: 1.5) +#' legend_text_size (default: 1.2) +#' legend_bg_color (default: "white") +#' legend_bg_alpha (default: 0.5) +#' scale (default: 1.0) +#' @return A plot object +#' +.plot_rgb <- function(tile, + red, + green, + blue, + date, + sf_seg = NULL, + seg_color = NULL, + line_width = 0.2, + tmap_options) { + # verifies if stars package is installed + .check_require_packages("stars") + # verifies if tmap package is installed + .check_require_packages("tmap") + + # get RGB files for the requested timeline + red_file <- .tile_path(tile, red, date) + green_file <- .tile_path(tile, green, date) + blue_file <- .tile_path(tile, blue, date) + + # size of data to be read + size <- .plot_read_size( + tile = tile, + tmap_options = tmap_options + ) + # read raster data as a stars object with separate RGB bands + rgb_st <- stars::read_stars( + c(red_file, green_file, blue_file), + along = "band", + RasterIO = list( + "nBufXSize" = size[["xsize"]], + "nBufYSize" = size[["ysize"]] + ), + proxy = FALSE + ) + # get the max values + band_params <- .tile_band_conf(tile, red) + max_value <- .max_value(band_params) + + rgb_st <- stars::st_rgb(rgb_st[, , , 1:3], + dimension = "band", + maxColorValue = max_value, + use_alpha = FALSE, + probs = c(0.05, 0.95), + stretch = TRUE + ) + tmap_options <- .plot_tmap_params(tmap_options) + + p <- tmap::tm_shape(rgb_st) + + tmap::tm_raster() + + tmap::tm_graticules( + labels.size = tmap_options[["graticules_labels_size"]] + ) + + tmap::tm_compass() + + # include segments + if (!purrr::is_null(sf_seg)) { + p <- p + tmap::tm_shape(sf_seg) + + tmap::tm_borders(col = seg_color, lwd = line_width) + } + + return(p) +} #' @title Plot probs #' @name .plot_probs #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} @@ -193,14 +279,14 @@ #' @param labels_plot Labels to be plotted #' @param palette A sequential RColorBrewer palette #' @param rev Reverse the color palette? -#' @param tmap_options List with optional tmap parameters -#' tmap max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) -#' +#' @param tmap_options Named vector with optional tmap parameters +#' max_cells (default: 1e+06) +#' graticules_labels_size (default: 0.7) +#' legend_title_size (default: 1.5) +#' legend_text_size (default: 1.2) +#' legend_bg_color (default: "white") +#' legend_bg_alpha (default: 0.5) +#' scale (default: 1.0) #' @return A plot object #' .plot_probs <- function(tile, @@ -269,16 +355,21 @@ midpoint = 0.5, title = labels[labels %in% labels_plot] ) + - tmap::tm_facets(free.coords = TRUE) + + tmap::tm_graticules( + labels.size = tmap_params[["graticules_labels_size"]] + ) + + tmap::tm_facets(sync = FALSE) + tmap::tm_compass() + tmap::tm_layout( - legend.show = TRUE, - legend.outside = FALSE, + scale = tmap_params[["scale"]], + fontfamily = tmap_params[["font_family"]], + legend.show = TRUE, + legend.outside = FALSE, legend.bg.color = tmap_params[["legend_bg_color"]], legend.bg.alpha = tmap_params[["legend_bg_alpha"]], legend.title.size = tmap_params[["legend_title_size"]], legend.text.size = tmap_params[["legend_text_size"]], - outer.margins = 0 + legend.width = tmap_params[["legend_width"]] ) return(p) @@ -349,92 +440,6 @@ return(p) } -#' @title Plot a RGB image -#' @name .plot_rgb -#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @keywords internal -#' @noRd -#' @param tile Tile to be plotted -#' @param red Band to be plotted in red -#' @param green Band to be plotted in green -#' @param blue Band to be plotted in blue -#' @param date Date to be plotted -#' @param sf_seg Segments (sf object) -#' @param seg_color Color to use for segment borders -#' @param line_width Line width to plot the segments boundary -#' @param tmap_options List with optional tmap parameters -#' tmap max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) -#' -#' @return A plot object -#' -.plot_rgb <- function(tile, - red, - green, - blue, - date, - sf_seg = NULL, - seg_color = NULL, - line_width = 0.2, - tmap_options) { - # verifies if stars package is installed - .check_require_packages("stars") - # verifies if tmap package is installed - .check_require_packages("tmap") - - # get RGB files for the requested timeline - red_file <- .tile_path(tile, red, date) - green_file <- .tile_path(tile, green, date) - blue_file <- .tile_path(tile, blue, date) - - # size of data to be read - size <- .plot_read_size( - tile = tile, - tmap_options = tmap_options - ) - # read raster data as a stars object with separate RGB bands - rgb_st <- stars::read_stars( - c(red_file, green_file, blue_file), - along = "band", - RasterIO = list( - "nBufXSize" = size[["xsize"]], - "nBufYSize" = size[["ysize"]] - ), - proxy = FALSE - ) - # get the max values - band_params <- .tile_band_conf(tile, red) - max_value <- .max_value(band_params) - - rgb_st <- stars::st_rgb(rgb_st[, , , 1:3], - dimension = "band", - maxColorValue = max_value, - use_alpha = FALSE, - probs = c(0.05, 0.95), - stretch = TRUE - ) - - tmap_params <- .plot_tmap_params(tmap_options) - - p <- tmap::tm_shape(rgb_st) + - tmap::tm_raster() + - tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] - ) + - tmap::tm_compass() - - # include segments - if (!purrr::is_null(sf_seg)) { - p <- p + tmap::tm_shape(sf_seg) + - tmap::tm_borders(col = seg_color, lwd = line_width) - } - - return(p) -} #' @title Return the cell size for the image to be reduced for plotting #' @name .plot_read_size #' @keywords internal @@ -442,26 +447,16 @@ #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' #' @param tile Tile to be plotted. -#' @param tmap_options List with optional tmap parameters -#' tmap max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) +#' @param tmap_options Named vector with options #' @return Cell size for x and y coordinates. #' #' .plot_read_size <- function(tile, tmap_options) { # get the maximum number of bytes to be displayed - if (!purrr::is_null(tmap_options[["max_cells"]])) { - max_cells <- tmap_options[["max_cells"]] - } else { - max_cells <- as.numeric(.conf("tmap", "max_cells")) - } - max_raster <- c(plot = max_cells, view = max_cells) + max_cells <- 1e+07 + # max_raster <- c(plot = max_cells, view = max_cells) # set the options for tmap - tmap::tmap_options(max.raster = max_raster) + # tmap::tmap_options(max.raster = max_raster) # numbers of nrows and ncols nrows <- max(.tile_nrows(tile)) ncols <- max(.tile_ncols(tile)) @@ -487,86 +482,51 @@ #' @noRd #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' -#' @param tmap_options List with optional tmap parameters +#' @param tmap_user Named vector with optional tmap parameters #' @return Updated tmap params. #' -.plot_tmap_params <- function(tmap_options) { - # set the tmap options - graticules_labels_size <- as.numeric(.conf("tmap", "graticules_labels_size")) - legend_title_size <- as.numeric(.conf("tmap", "legend_title_size")) - legend_text_size <- as.numeric(.conf("tmap", "legend_text_size")) - legend_width <- as.numeric(.conf("tmap", "legend_width")) - legend_height <- as.numeric(.conf("tmap", "legend_height")) - legend_position <- .conf("tmap", "legend_position") - legend_outside <- .conf("tmap", "legend_outside") - legend_outside_position <- .conf("tmap", "legend_outside_position") - legend_bg_color <- .conf("tmap", "legend_bg_color") - legend_bg_alpha <- as.numeric(.conf("tmap", "legend_bg_alpha")) - scale <- as.numeric(.conf("tmap", "scale")) - font_family <- .conf("tmap", "font_family") - - # user specified tmap options - if (!purrr::is_null(tmap_options)) { - # scale - if (!purrr::is_null(tmap_options[["scale"]])) { - scale <- as.numeric(tmap_options[["scale"]]) - } - # font_family - if (!purrr::is_null(tmap_options[["font_family"]])) { - font_family <- as.numeric(tmap_options[["font_family"]]) - } - # graticules label size - if (!purrr::is_null(tmap_options[["graticules_labels_size"]])) { - graticules_labels_size <- as.numeric( - tmap_options[["graticules_labels_size"]]) - } - # legend title size - if (!purrr::is_null(tmap_options[["legend_title_size"]])) { - legend_title_size <- as.numeric(tmap_options[["legend_title_size"]]) - } - # legend text size - if (!purrr::is_null(tmap_options[["legend_text_size"]])) { - legend_text_size <- as.numeric(tmap_options[["legend_text_size"]]) - } - # tmap legend bg color - if (!purrr::is_null(tmap_options[["legend_bg_color"]])) { - legend_bg_color <- tmap_options[["legend_bg_color"]] - } - # tmap legend bg alpha - if (!purrr::is_null(tmap_options[["legend_bg_alpha"]])) { - legend_bg_alpha <- as.numeric(tmap_options[["legend_bg_alpha"]]) - } - # tmap legend height - if (!purrr::is_null(tmap_options[["legend_height"]])) { - legend_height <- as.numeric(tmap_options[["legend_height"]]) - } - if (!purrr::is_null(tmap_options[["legend_width"]])) { - legend_width <- as.numeric(tmap_options[["legend_width"]]) - } - if (!purrr::is_null(tmap_options[["legend_position"]])) { - legend_position <- tmap_options[["legend_position"]] - } - if (!purrr::is_null(tmap_options[["legend_outside"]])) { - legend_outside <- tmap_options[["legend_outside"]] - } - if (!purrr::is_null(tmap_options[["legend_outside_position"]])) { - legend_outside_position <- - tmap_options[["legend_outside_position"]] - } - } - tmap_params <- list( - "scale" = scale, - "font_family" = font_family, - "graticules_labels_size" = graticules_labels_size, - "legend_title_size" = legend_title_size, - "legend_text_size" = legend_text_size, - "legend_bg_color" = legend_bg_color, - "legend_bg_alpha" = legend_bg_alpha, - "legend_height" = legend_height, - "legend_width" = legend_width, - "legend_position" = legend_position, - "legend_outside" = legend_outside, - "legend_outside_position" = legend_outside_position +.plot_tmap_params <- function(tmap_user) { + # reset the tmap params + suppressMessages(tmap::tmap_options_reset()) + # get the tmap defaults + tmap_options <- list( + graticules_labels_size = + as.numeric(.conf("tmap", "graticules_labels_size")), + legend_title_size = as.numeric(.conf("tmap", "legend_title_size")), + legend_text_size = as.numeric(.conf("tmap", "legend_text_size")), + legend_width = as.numeric(.conf("tmap", "legend_width")), + legend_height = as.numeric(.conf("tmap", "legend_height")), + legend_position = .conf("tmap", "legend_position"), + legend_outside = .conf("tmap", "legend_outside"), + legend_outside_position = .conf("tmap", "legend_outside_position"), + legend_bg_color = .conf("tmap", "legend_bg_color"), + legend_bg_alpha = as.numeric(.conf("tmap", "legend_bg_alpha")), + scale = as.numeric(.conf("tmap", "scale")), + n_breaks = as.numeric(.conf("tmap", "n_breaks")), + font_family = .conf("tmap", "font_family") ) - return(tmap_params) + if (!purrr::is_null(tmap_user)) { + keys <- unique(c(names(tmap_user), names(tmap_options))) + .check_that( + all(keys %in% names(tmap_options)), + msg = paste("invalid tmap params - valid params are ", + keys, collapse = " ") + ) + for (k in names(tmap_user)) + tmap_options[[k]] <- tmap_user[[k]] + } + # set tmap options + tmap::tmap_options(scale = as.numeric(tmap_options[["scale"]]), + legend.title.size = as.numeric(tmap_options[["legend_title_size"]]), + legend.text.size = as.numeric(tmap_options[["legend_text_size"]]), + legend.width = as.numeric(tmap_options[["legend_width"]]), + legend.height = as.numeric(tmap_options[["legend_height"]]), + legend.position = tmap_options[["legend_position"]], + legend.outside = tmap_options[["legend_outside"]], + legend.outside.position = tmap_options[["legend_outside_position"]], + legend.bg.color = tmap_options[["legend_bg_color"]], + legend.bg.alpha = as.numeric(tmap_options[["legend_bg_alpha"]]), + fontfamily = tmap_options[["font_family"]] + ) + return(tmap_options) } diff --git a/R/api_plot_vector.R b/R/api_plot_vector.R index 608f7c3b6..5f5e8cd69 100644 --- a/R/api_plot_vector.R +++ b/R/api_plot_vector.R @@ -7,13 +7,12 @@ #' @param tile Tile to be plotted. #' @param legend Legend for the classes #' @param palette A sequential RColorBrewer palette -#' @param tmap_options List with optional tmap parameters -#' tmap max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) +#' @param tmap_options Named vector with optional tmap parameters +#' graticules_labels_size (default: 0.7) +#' legend_title_size (default: 1.5) +#' legend_text_size (default: 1.2) +#' legend_bg_color (default: "white") +#' legend_bg_alpha (default: 0.5) #' #' @return A plot object #' @@ -42,7 +41,7 @@ rev = TRUE ) # set the tmap options - tmap_params <- .plot_tmap_params(tmap_options) + tmap_options <- .plot_tmap_params(tmap_options) # name the colors to match the labels names(colors) <- labels # join sf geometries @@ -56,20 +55,20 @@ palette = colors ) + tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] + labels.size = tmap_options[["graticules_labels_size"]] ) + tmap::tm_compass() + tmap::tm_layout( legend.show = TRUE, legend.outside = FALSE, - scale = tmap_params[["scale"]], - fontfamily = tmap_params[["font_family"]], - legend.bg.color = tmap_params[["legend_bg_color"]], - legend.bg.alpha = tmap_params[["legend_bg_alpha"]], - legend.title.size = tmap_params[["legend_title_size"]], - legend.text.size = tmap_params[["legend_text_size"]], - legend.width = tmap_params[["legend_width"]], - legend.position = tmap_params[["legend_position"]] + scale = tmap_options[["scale"]], + 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.position = tmap_options[["legend_position"]] ) + tmap::tm_borders(lwd = 0.2) return(p) @@ -84,13 +83,7 @@ #' @param labels_plot Labels to be plotted #' @param palette A sequential RColorBrewer palette #' @param rev Revert the color of the palette? -#' @param tmap_options List with optional tmap parameters -#' tmap max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) +#' @param tmap_options Named vector with optional tmap parameters #' #' @return A plot object #' @@ -124,35 +117,87 @@ # get the segements to be plotted sf_seg <- .segments_read_vec(tile) # set the tmap options - tmap_params <- .plot_tmap_params(tmap_options) - # set the mode to plot - tmap::tmap_mode("plot") + tmap_options <- .plot_tmap_params(tmap_options) # plot the segments by facet - # fix number of cols - if (length(labels_plot) < 2 ) - ncol_plot <- 1 - else - ncol_plot <- 2 + p <- tmap::tm_shape(sf_seg) + + tmap::tm_fill(labels_plot, + style = "cont", + palette = palette, + midpoint = 0.5, + title = labels[labels %in% labels_plot]) + + tmap::tm_graticules( + labels.size = tmap_options[["graticules_labels_size"]] + ) + + tmap::tm_facets() + + tmap::tm_compass() + + tmap::tm_layout( + scale = tmap_options[["scale"]], + fontfamily = tmap_options[["font_family"]], + legend.show = TRUE, + legend.outside = FALSE, + 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"]] + ) + + tmap::tm_borders(lwd = 0.1) + + 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(labels_plot) + - tmap::tm_facets(sync = FALSE, ncol = 2, scale.factor = 1) + + tmap::tm_polygons(uncert_type, + palette = palette, + style = "cont") + tmap::tm_graticules( - labels.size = tmap_params[["graticules_labels_size"]] + labels.size = tmap_options[["graticules_labels_size"]] ) + tmap::tm_compass() + tmap::tm_layout( - fontfamily = tmap_params[["font_family"]], - legend.bg.color = tmap_params[["legend_bg_color"]], - legend.bg.alpha = tmap_params[["legend_bg_alpha"]], - legend.title.size = tmap_params[["legend_title_size"]], - legend.text.size = tmap_params[["legend_text_size"]], - legend.width = tmap_params[["legend_width"]], - legend.height = tmap_params[["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 + legend.show = TRUE, + legend.outside = FALSE, + scale = tmap_options[["scale"]], + 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.position = tmap_options[["legend_position"]] ) + tmap::tm_borders(lwd = 0.2) diff --git a/R/api_regularize.R b/R/api_regularize.R index 7ca70acf2..9d8f22bc1 100644 --- a/R/api_regularize.R +++ b/R/api_regularize.R @@ -165,6 +165,8 @@ }) |> dplyr::bind_rows() + # Finalize customizing cube class + cube_class <- c(cube_class[1], "sar_cube", cube_class[-1]) .cube_set_class(cube, cube_class) } diff --git a/R/api_segments.R b/R/api_segments.R index f61429305..01784a770 100755 --- a/R/api_segments.R +++ b/R/api_segments.R @@ -1,3 +1,18 @@ +#' +#' @name .segments_tile +#' @keywords internal +#' @noRd +#' @description Extract the segments from a tile +#' +#' @param tile tile of regular data cube +#' @param seg_fn Segmentation function to be used +#' @param band Name of output band +#' @param block Block size +#' @param roi Region of interest +#' @param output_dir Directory for saving temporary segment files +#' @param version Version of the result +#' @param progress Show progress bar? +#' @return segments for the tile .segments_tile <- function(tile, seg_fn, band, @@ -67,7 +82,7 @@ values <- C_fill_na(values, 0) # Used to check values (below) input_pixels <- nrow(values) - # Apply segment function + # Apply segmentation function values <- seg_fn(values, block, bbox) # Check if the result values is a vector object .check_vector(values) @@ -92,8 +107,13 @@ # Return segments tile seg_tile } - - +#' @name .segments_is_valud +#' @keywords internal +#' @noRd +#' @description Check if segments file is valid +#' +#' @param file GKPG file containing the segments +#' @return TRUE/FALSE .segments_is_valid <- function(file) { # resume processing in case of failure if (!all(file.exists(file))) { @@ -115,7 +135,14 @@ } return(TRUE) } - +#' @name .segments_data_read +#' @keywords internal +#' @noRd +#' @description Extract the segments from a tile +#' +#' @param tile Tile of regular data cube +#' @param block Block size +#' @return values of the time series in the block .segments_data_read <- function(tile, block) { # For cubes that have a time limit to expire (MPC cubes only) tile <- .cube_token_generator(tile) @@ -149,44 +176,124 @@ values } -.get_segments_from_cube <- function(cube) { - slider::slide_dfr(cube, function(tile) { - .segments_read_vec(tile) - }) -} - +#' @name .segments_path +#' @keywords internal +#' @noRd +#' @description Find the path to the GPKG file with the segments +#' +#' @param cube Regular data cube +#' @return GPKG file name .segments_path <- function(cube) { slider::slide_chr(cube, function(tile) { tile[["vector_info"]][[1]][["path"]] }) } - +#' @name .segments_read_vec +#' @keywords internal +#' @noRd +#' @description Read the segments associated to a tile +#' @param cube Regular data cube +#' @return segment vectors (sf object) .segments_read_vec <- function(cube) { tile <- .tile(cube) vector_seg <- .vector_read_vec(.segments_path(tile)) return(vector_seg) } +#' @name .segments_join_probs +#' @keywords internal +#' @noRd +#' @description Join the probabilities of time series inside each +#' segment to the segments vectors +#' @param data Classified time series +#' @param segments Segments object (sf object) +#' @return segment vectors (sf object) with the probabilities +#' +.segments_join_probs <- function(data, segments) { + # Select polygon_id and class for the time series tibble + data <- data |> + dplyr::select("polygon_id", "predicted") |> + dplyr::mutate(polygon_id = as.numeric(.data[["polygon_id"]])) |> + tidyr::unnest(cols = "predicted") |> + dplyr::select(-"class") |> + dplyr::group_by(.data[["polygon_id"]]) + # Select just probability labels + labels <- setdiff(colnames(data), c("polygon_id", "from", "to", "class")) + # Calculate metrics + data <- dplyr::summarise( + data, + dplyr::across(.cols = dplyr::all_of(labels), + .names = "{.col}_mean", mean) + ) + # Summarize probabilities + data <- data |> + dplyr::rename_with(~ gsub("_mean$", "", .x)) |> + dplyr::rowwise() |> + dplyr::mutate(sum = sum(dplyr::c_across(cols = dplyr::all_of(labels)))) |> + dplyr::mutate(dplyr::across(.cols = dplyr::all_of(labels), ~ .x / .data[["sum"]])) |> + dplyr::select(-"sum") -.segments_join_probs <- function(data, segments, aggregate) { + # join the data_id tibble with the segments (sf objects) + dplyr::left_join(segments, data, by = c("pol_id" = "polygon_id")) +} +#' @name .segments_join_probs_neigh +#' @keywords internal +#' @noRd +#' @description Join the probabilities of time series inside each +#' segment to the segments vectors +#' Include neighbour information +#' @param data Classified time series +#' @param segments Segments object (sf object) +#' @return segment vectors (sf object) with the probabilities +#' +.segments_join_probs_neigh <- function(data, segments) { # Select polygon_id and class for the time series tibble - data_id <- data |> + data <- data |> dplyr::select("polygon_id", "predicted") |> dplyr::mutate(polygon_id = as.numeric(.data[["polygon_id"]])) |> tidyr::unnest(cols = "predicted") |> dplyr::select(-"class") |> dplyr::group_by(.data[["polygon_id"]]) # Select just probability labels - labels <- setdiff(colnames(data_id), c("polygon_id", "from", "to", "class")) + labels <- setdiff(colnames(data), c("polygon_id", "from", "to", "class")) + # Calculate metrics + data_id <- dplyr::summarise( + data, + dplyr::across(.cols = dplyr::all_of(labels), + .names = "{.col}_mean", mean), + dplyr::across(.cols = dplyr::all_of(labels), + .names = "{.col}_var", stats::var) + ) + # Summarize probabilities + data_id <- data_id |> + dplyr::rename_with(~ gsub("_mean$", "", .x)) |> + dplyr::rowwise() |> + dplyr::mutate(sum = sum(dplyr::c_across(cols = dplyr::all_of(labels)))) |> + dplyr::mutate(dplyr::across(.cols = dplyr::all_of(labels), ~ .x / .data[["sum"]])) |> + dplyr::select(-"sum") - if (aggregate) { - data_id <- data_id |> - dplyr::summarise(dplyr::across(.cols = dplyr::all_of(labels), stats::median)) |> - dplyr::rowwise() |> - dplyr::mutate(sum = sum(dplyr::c_across(cols = dplyr::all_of(labels)))) |> - dplyr::mutate(dplyr::across(.cols = dplyr::all_of(labels), ~ .x / .data[["sum"]])) |> - dplyr::select(-"sum") - } + # Get the information about the neighbours + neighbors <- spdep::poly2nb(segments) + # ungroup the data tibble + data <- dplyr::ungroup(data) + # obtain neighborhood statistics for each polygon + neigh_stats <- purrr::map_dfr(unique(data$polygon_id), function(id){ + # get the ids of the neighbours of a polygon + ids <- neighbors[[id]] + # get mean and variance of the neighbours per class + neigh <- data |> + dplyr::filter(.data[["polygon_id"]] %in% ids) |> + dplyr::select(!!labels) |> + dplyr::summarise( + dplyr::across(.cols = dplyr::all_of(labels), + .names = "{.col}_nmean", mean), + dplyr::across(.cols = dplyr::all_of(labels), + .names = "{.col}_nvar", stats::var) + ) + return(neigh) + }) + # include neighborhood statistics in the results + data_id <- dplyr::bind_cols(data_id, neigh_stats) # join the data_id tibble with the segments (sf objects) dplyr::left_join(segments, data_id, by = c("pol_id" = "polygon_id")) @@ -296,10 +403,12 @@ ) # unnest to obtain the samples. samples <- tidyr::unnest(samples, cols = "points") - # sample the values - samples <- dplyr::slice_sample(samples, - n = n_sam_pol, - by = "polygon_id") + # sample the values if n_sam_plot is not NULL + if (!purrr::is_null(n_sam_pol)) { + samples <- dplyr::slice_sample(samples, + n = n_sam_pol, + by = "polygon_id") + } samples <- .discard(samples, "sample_id") # set sits class class(samples) <- c("sits", class(samples)) diff --git a/R/api_source_mpc.R b/R/api_source_mpc.R index 4ea109541..57080d78c 100644 --- a/R/api_source_mpc.R +++ b/R/api_source_mpc.R @@ -295,7 +295,7 @@ `.source_items_tile.mpc_cube_sentinel-1-grd` <- function(source, items, ..., collection = NULL) { - rep("20LKP", rstac::items_length(items)) + rep("NoTilingSystem", rstac::items_length(items)) } #' @keywords internal diff --git a/R/api_uncertainty.R b/R/api_uncertainty.R index 78b7172ef..db77958c3 100644 --- a/R/api_uncertainty.R +++ b/R/api_uncertainty.R @@ -1,6 +1,6 @@ #---- internal functions ---- -#' @title Create an uncertainty cube -#' @name .uncertainty_cube +#' @title Create an uncertainty raster cube +#' @name .uncertainty_raster_cube #' @keywords internal #' @noRd #' @param cube A cube @@ -9,7 +9,7 @@ #' @param output_dir directory where files will be saved #' @param version version name of resulting cube#' #' @return uncertainty cube -.uncertainty_cube <- function(cube, +.uncertainty_raster_cube <- function(cube, band, uncert_fn, output_dir, @@ -17,7 +17,7 @@ # Process each tile sequentially uncert_cube <- .cube_foreach_tile(cube, function(tile) { # Compute uncertainty - uncert_tile <- .uncertainty_tile( + uncert_tile <- .uncertainty_raster_tile( tile = tile, band = band, uncert_fn = uncert_fn, @@ -29,16 +29,16 @@ return(uncert_cube) } #' @title Create an uncertainty tile-band asset -#' @name .uncertainty_tile +#' @name .uncertainty_raster_tile #' @keywords internal #' @noRd #' @param tile tile of data cube #' @param band band name #' @param uncert_fn function to compute uncertainty #' @param output_dir directory where files will be saved -#' @param version version name of resulting cube#' +#' @param version version name of resulting cube #' @return uncertainty tile-band combination -.uncertainty_tile <- function(tile, +.uncertainty_raster_tile <- function(tile, band, uncert_fn, output_dir, @@ -53,7 +53,7 @@ # Resume feature if (file.exists(out_file)) { .check_recovery(tile[["tile"]]) - + # return the existing tile uncert_tile <- .tile_derived_from_file( file = out_file, band = band, @@ -62,6 +62,7 @@ ) return(uncert_tile) } + # If output file does not exist # Create chunks as jobs chunks <- .tile_chunks_create(tile = tile, overlap = 0) # Process jobs in parallel @@ -129,6 +130,89 @@ uncert_tile } +#---- internal functions ---- +#' @title Create an uncertainty raster cube +#' @name .uncertainty_vector_cube +#' @keywords internal +#' @noRd +#' @param cube A cube +#' @param band band name +#' @param output_dir directory where files will be saved +#' @param version version name of resulting cube#' +#' @return uncertainty cube +.uncertainty_vector_cube <- function(cube, + band, + output_dir, + version) { + # Process each tile sequentially + uncert_cube <- .cube_foreach_tile(cube, function(tile) { + # Compute uncertainty + uncert_tile <- .uncertainty_vector_tile( + tile = tile, + band = band, + output_dir = output_dir, + version = version + ) + return(uncert_tile) + }) + class(uncert_cube) <- c("uncertainty_vector_cube", class(cube)) + return(uncert_cube) +} +#' @title Create an uncertainty vector tile +#' @name .uncertainty_vector_tile +#' @keywords internal +#' @noRd +#' @param tile tile of data cube +#' @param band band name +#' @param output_dir directory where files will be saved +#' @param version version name of resulting cube +#' @return uncertainty tile-band combination +.uncertainty_vector_tile <- function(tile, + band, + output_dir, + version) { + # Output file + out_file <- .file_derived_name( + tile = tile, + band = band, + version = version, + output_dir = output_dir, + ext = "gpkg" + ) + # select uncertainty function + uncert_fn <- switch( + band, + "least" = .uncertainty_fn_least(), + "margin" = .uncertainty_fn_margin(), + "entropy" = .uncertainty_fn_entropy() + ) + # get the labels + labels <- unname(sits_labels(tile)) + # read the segments + sf_seg <- .segments_read_vec(tile) + # extract matrix values from segments + probs_matrix <- sf_seg |> + sf::st_drop_geometry() |> + dplyr::select(dplyr::all_of(labels)) |> + as.matrix() + # apply uncertainty function + uncert_values <- uncert_fn(probs_matrix) + colnames(uncert_values) <- band + uncert_values <- tibble::as_tibble(uncert_values) + # merge uncertainty values + sf_seg <- sf_seg |> + dplyr::bind_cols(uncert_values) |> + dplyr::relocate(dplyr::all_of(band), .before = "geom") + # Prepare and save results as vector + .vector_write_vec(v_obj = sf_seg, file_path = out_file) + # Set information on uncert_tile + uncert_tile <- tile + uncert_tile$vector_info[[1]]$band <- band + uncert_tile$vector_info[[1]]$path <- out_file + class(uncert_tile) <- c("uncertainty_vector_cube", class(uncert_tile)) + return(uncert_tile) +} + #---- uncertainty functions ---- #' @title Least uncertainty function #' @name .uncertainty_fn_least diff --git a/R/api_view.R b/R/api_view.R index 0ad8f47f8..7999b7371 100644 --- a/R/api_view.R +++ b/R/api_view.R @@ -935,6 +935,21 @@ } #' #' @export +.view_add_overlay_grps.class_cube <- function(cube, ..., + dates = NULL, + class_cube = NULL) { + + # overlay_groups <- NULL + # grps <- unlist(purrr::map(cube[["tile"]], function(tile) { + # paste(tile, .cube_bands(cube)) + # })) + # overlay_groups <- c(overlay_groups, grps) + # # add class_cube + overlay_groups <- c("classification") + return(overlay_groups) +} +#' +#' @export .view_add_overlay_grps.vector_cube <- function(cube, ..., dates = NULL, class_cube = NULL) { diff --git a/R/sits_accuracy.R b/R/sits_accuracy.R index cfcb0a43e..536b5b058 100644 --- a/R/sits_accuracy.R +++ b/R/sits_accuracy.R @@ -129,8 +129,6 @@ sits_accuracy.sits <- function(data, ...) { #' @rdname sits_accuracy #' @export sits_accuracy.class_cube <- function(data, ..., validation) { - # check the cube is valid - .check_cube_files(data) # generic function # Is this a CSV file? if (is.character(validation)) { @@ -238,38 +236,10 @@ sits_accuracy.class_cube <- function(data, ..., validation) { ) ) - # Get area for each class for each row of the cube - freq_lst <- slider::slide(data, function(tile) { - # Get the frequency count and value for each labelled image - freq <- .tile_area_freq(tile) - # pixel area - # convert the area to hectares - # assumption: spatial resolution unit is meters - area <- freq$count * .tile_xres(tile) * .tile_yres(tile) / 10000 - # Include class names - freq <- dplyr::mutate(freq, - area = area, - class = labels_cube[.as_chr(freq$value)] - ) - return(freq) - }) - # Get a tibble by binding the row (duplicated labels with different counts) - freq <- do.call(rbind, freq_lst) - # summarize the counts for each label - freq <- freq |> - dplyr::filter(!is.na(class)) |> - dplyr::group_by(class) |> - dplyr::summarise(area = sum(.data[["area"]])) - - # Area is taken as the sum of pixels - area <- freq$area - # Names of area are the classes - names(area) <- freq$class - # NAs are set to 0 - area[is.na(area)] <- 0 - + # Get area for each class of the cube + class_areas <- .cube_class_areas(data) # Compute accuracy metrics - acc_area <- .accuracy_area_assess(data, error_matrix, area) + acc_area <- .accuracy_area_assess(data, error_matrix, class_areas) class(acc_area) <- c("sits_area_accuracy", class(acc_area)) return(acc_area) diff --git a/R/sits_classify.R b/R/sits_classify.R index 189caab7d..66582ca30 100644 --- a/R/sits_classify.R +++ b/R/sits_classify.R @@ -132,9 +132,8 @@ #' data = segments, #' ml_model = rf_model, #' output_dir = tempdir(), -#' n_sam_pol = 20, #' multicores = 4, -#' version = "segs_classify" +#' version = "segs" #' ) #' # Create a labelled vector cube #' class_segs <- sits_label_classification( @@ -170,7 +169,7 @@ sits_classify.sits <- function(data, .check_is_sits_model(ml_model) .check_multicores(multicores, min = 1, max = 2048) .check_progress(progress) - # Update multicores: xgb model do its own parallelization + # Update multicores: xgb model does its own parallelization if (inherits(ml_model, "xgb_model")) { multicores <- 1 } @@ -351,14 +350,14 @@ sits_classify.segs_cube <- function(data, gpu_memory = 16, output_dir, version = "v1", - n_sam_pol = 40, + n_sam_pol = NULL, verbose = FALSE, progress = TRUE) { # preconditions .check_is_vector_cube(data) .check_is_sits_model(ml_model) - .check_int_parameter(n_sam_pol, min = 5, max = 50) + .check_int_parameter(n_sam_pol, min = 5, allow_null = TRUE) .check_memsize(memsize, min = 1, max = 16384) .check_multicores(multicores, min = 1, max = 2048) .check_output_dir(output_dir) diff --git a/R/sits_clean.R b/R/sits_clean.R new file mode 100644 index 000000000..82cc0a32a --- /dev/null +++ b/R/sits_clean.R @@ -0,0 +1,165 @@ +#' @title Cleans a classified map using a local window +#' +#' @name sits_clean +#' +#' @author Felipe Carvalho, \email{felipe.carvalho@@inpe.br} +#' +#' @description +#' Applies a modal function to clean up possible noisy pixels keeping +#' the most frequently values within the neighborhood. +#' In a tie, the first value of the vector is considered. +#' +#' @param cube Classified data cube (tibble of class "class_cube"). +#' @param window_size An odd integer representing the size of the +#' sliding window of the modal function (min = 1, max = 15). +#' @param memsize Memory available for classification in GB +#' (integer, min = 1, max = 16384). +#' @param multicores Number of cores to be used for classification +#' (integer, min = 1, max = 2048). +#' @param output_dir Valid directory for output file. +#' (character vector of length 1). +#' @param version Version of the output file +#' (character vector of length 1) +#' @param progress Logical: Show progress bar? +#' +#' @return A tibble with an classified map (class = "class_cube"). +#' +#' @examples +#' if (sits_run_examples()) { +#' rf_model <- sits_train(samples_modis_ndvi, ml_method = 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 +#' ) +#' # classify a data cube +#' probs_cube <- sits_classify( +#' data = cube, +#' ml_model = rf_model, +#' output_dir = tempdir() +#' ) +#' # label the probability cube +#' label_cube <- sits_label_classification( +#' probs_cube, +#' output_dir = tempdir() +#' ) +#' # apply a mode function in the labelled cube +#' clean_cube <- sits_clean( +#' cube = label_cube, +#' window_size = 5, +#' output_dir = tempdir(), +#' multicores = 1 +#' ) +#' } +#' +#' @export +sits_clean <- function(cube, window_size = 5L, memsize = 4L, + multicores = 2L, output_dir, version = "v1-clean", + progress = TRUE) { + # Precondition + # Check the cube is valid + .check_valid(cube) + UseMethod("sits_clean", cube) +} +#' @rdname sits_clean +#' @export +sits_clean.class_cube <- function(cube, window_size = 5L, memsize = 4L, + multicores = 2L, output_dir, + version = "v1-clean", progress = TRUE) { + # Preconditions + # Check cube has files + .check_raster_cube_files(cube) + # Check window size + .check_window_size(window_size, min = 1, max = 15) + # Check memsize + .check_memsize(memsize, min = 1, max = 16384) + # Check multicores + .check_multicores(multicores, min = 1, max = 2048) + # Check output_dir + .check_output_dir(output_dir) + # Check version + .check_version(version) + # version is case-insensitive in sits + version <- tolower(version) + # Check progress + .check_progress(progress) + + # Get input band + band <- .cube_bands(cube) + # image size + image_size <- .raster_size(.raster_open_rast(.tile_path(cube))) + # Overlapping pixels + overlap <- ceiling(window_size / 2) - 1 + # Check minimum memory needed to process one block + job_memsize <- .jobs_memsize( + job_size = .block_size(block = image_size, overlap = overlap), + npaths = 1, nbytes = 8, + proc_bloat = .conf("processing_bloat") + ) + # Update multicores parameter + multicores <- .jobs_max_multicores( + job_memsize = job_memsize, memsize = memsize, multicores = multicores + ) + # Prepare parallelization + .parallel_start(workers = multicores) + on.exit(.parallel_stop(), add = TRUE) + + # Process each tile sequentially + clean_cube <- .cube_foreach_tile(cube, function(tile) { + # Process the data + clean_tile <- .clean_tile( + tile = tile, + block = image_size, + band = band, + window_size = window_size, + overlap = overlap, + output_dir = output_dir, + version = version + ) + return(clean_tile) + }) + # Update cube class + class(clean_cube) <- c("class_cube", class(clean_cube)) + # Return cleaned cube + return(clean_cube) +} + +#' @rdname sits_clean +#' @export +sits_clean.raster_cube <- function(cube, window_size = 5L, memsize = 4L, + multicores = 2L, output_dir, + version = "v1-clean", progress = TRUE) { + stop("Input should be a classified cube") + return(cube) +} +#' @rdname sits_clean +#' @export +sits_clean.derived_cube <- function(cube, window_size = 5L, memsize = 4L, + multicores = 2L, output_dir, + version = "v1-clean", progress = TRUE) { + stop("Input should be a classified cube") + return(cube) +} +#' @rdname sits_clean +#' @export +sits_clean.tbl_df <- function(cube, window_size = 5L, memsize = 4L, + multicores = 2L, output_dir, + version = "v1-clean", progress = TRUE) { + cube <- tibble::as_tibble(cube) + if (all(.conf("sits_cube_cols") %in% colnames(cube))) { + cube <- .cube_find_class(cube) + } else + stop("Input should be a classified cube") + clean_cube <- sits_clean(cube, window_size, memsize, multicores, + output_dir, version, progress) + return(clean_cube) +} +#' @rdname sits_clean +#' @export +sits_clean.default <- function(cube, window_size = 5L, memsize = 4L, + multicores = 2L, output_dir, + version = "v1-clean", progress = TRUE) { + stop("Input should be a classified cube") +} diff --git a/R/sits_colors.R b/R/sits_colors.R index ecfe4aa94..1ee05460d 100644 --- a/R/sits_colors.R +++ b/R/sits_colors.R @@ -14,12 +14,11 @@ #' @export #' sits_colors <- function(legend = NULL) { - legends <- .conf("legends") if (purrr::is_null(legend)) { print("Returning all available colors") - return(.conf_colors()) + return(sits_env$color_table) } else { - if (legend %in% legends) { + if (legend %in% sits_env$legends) { colors <- .conf(legend) color_table_legend <- .conf_colors() |> dplyr::filter(.data[["name"]] %in% colors) @@ -29,7 +28,7 @@ sits_colors <- function(legend = NULL) { } else { print("Selected map legend not available") leg <- paste0(paste("Please select one of the legends: "), - paste(legends, collapse = ", ")) + paste(names(sits_env$legends), collapse = ", ")) print(leg) return(NULL) } @@ -52,26 +51,22 @@ sits_colors <- function(legend = NULL) { #' @export #' sits_colors_show <- function(legend = NULL, - font_family = "plex_sans") { + font_family = "sans") { # verifies if sysfonts package is installed .check_require_packages("sysfonts") - # checks if font family is available - if (!font_family %in% sysfonts::font_families()) - font_family <- "plex_sans" # legend must be valid - legends <- .conf("legends") if (purrr::is_null(legend)) legend <- "none" - if (!(legend %in% legends)) { + if (!(legend %in% names(sits_env$legends))) { msg <- paste0(paste("Please select one of the legends: "), - paste(legends, collapse = ", ")) + paste(names(sits_env$legends), collapse = ", ")) print(msg) return(invisible(NULL)) } # retrieve the color names associated to the legend - colors <- .conf(legend) + colors <- sits_env$legends[[legend]] # retrive the HEX codes associated to each color - color_table_legend <- .conf_colors() |> + color_table_legend <- sits_env$color_table |> dplyr::filter(.data[["name"]] %in% colors) # order the colors to match the order of the legend color_table_legend <- color_table_legend[ @@ -85,36 +80,77 @@ sits_colors_show <- function(legend = NULL, #' @title Function to set sits color table #' @name sits_colors_set #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} -#' @description Sets a color table -#' @param color_tb New color table -#' @return A modified sits color table +#' @description Includes new colors in the SITS color sets. If the colors exist, +#' replace them with the new HEX value. Optionally, the new colors +#' can be associated to a legend. In this case, the new legend +#' name should be informed. +#' The colors parameter should be a data.frame or a tibble +#' with name and HEX code. Colour names should be one character +#' string only. Composite names need to be combined with +#' underscores (e.g., use "Snow_and_Ice" instead of "Snow and Ice"). +#' +#' This function changes the global sits color table and the +#' global set of sits color legends. To undo these effects, +#' please use "sits_colors_reset()". +#' +#' @param colors New color table (a tibble or data.frame with name and HEX code) +#' @param legend Legend associated to the color table (optional) +#' @return A modified sits color table (invisible) #' #' @examples #' if (sits_run_examples()) { #' # Define a color table based on the Anderson Land Classification System #' us_nlcd <- tibble::tibble(name = character(), color = character()) #' us_nlcd <- us_nlcd |> -#' tibble::add_row(name = "Urban Built Up", color = "#85929E") |> -#' tibble::add_row(name = "Agricultural Land", color = "#F0B27A") |> +#' tibble::add_row(name = "Urban_Built_Up", color = "#85929E") |> +#' tibble::add_row(name = "Agricultural_Land", color = "#F0B27A") |> #' tibble::add_row(name = "Rangeland", color = "#F1C40F") |> -#' tibble::add_row(name = "Forest Land", color = "#27AE60") |> +#' tibble::add_row(name = "Forest_Land", color = "#27AE60") |> #' tibble::add_row(name = "Water", color = "#2980B9") |> #' tibble::add_row(name = "Wetland", color = "#D4E6F1") |> -#' tibble::add_row(name = "Barren Land", color = "#FDEBD0") |> +#' tibble::add_row(name = "Barren_Land", color = "#FDEBD0") |> #' tibble::add_row(name = "Tundra", color = "#EBDEF0") |> -#' tibble::add_row(name = "Snow and Ice", color = "#F7F9F9") +#' tibble::add_row(name = "Snow_and_Ice", color = "#F7F9F9") #' #' # Load the color table into `sits` -#' sits_colors_set(us_nlcd) +#' sits_colors_set(colors = us_nlcd, legend = "US_NLCD") #' #' # Show the new color table used by sits -#' sits_colors_show() +#' sits_colors_show("US_NLCD") +#' +#' # Change colors in the sits global color table +#' # First show the default colors for the UMD legend +#' sits_colors_show("UMD") +#' # Then change some colors associated to the UMD legend +#' mycolors <- tibble::tibble(name = character(), color = character()) +#' mycolors <- mycolors |> +#' tibble::add_row(name = "Savannas", color = "#F8C471") |> +#' tibble::add_row(name = "Grasslands", color = "#ABEBC6") +#' sits_colors_set(colors = mycolors) +#' # Notice that the UMD colors change +#' sits_colors_show("UMD") +#' # Reset the color table +#' sits_colors_reset() +#' # Show the default colors for the UMD legend +#' sits_colors_show("UMD") #' } #' @export #' -sits_colors_set <- function(color_tb) { - .conf_set_color_table(color_tb) - return(invisible(color_tb)) +sits_colors_set <- function(colors, legend = NULL) { + # add the new color table + new_color_tb <- .conf_add_color_table(colors) + if (!purrr::is_null(legend)) { + # add the list of color names to a new legend + .check_chr_parameter(legend, msg = "invalid legend") + # crete a new legend entry + new_legend_entry <- list() + # add the colors from the color table + new_legend_entry[[1]] <- dplyr::pull(colors, .data[["name"]]) + # give a new to the new legend entry + names(new_legend_entry) <- legend + sits_env$legends <- c(sits_env$legends, new_legend_entry) + } + return(invisible(new_color_tb)) } #' @title Function to reset sits color table #' @name sits_colors_reset diff --git a/R/sits_config.R b/R/sits_config.R index eb073419e..e48752443 100644 --- a/R/sits_config.R +++ b/R/sits_config.R @@ -55,8 +55,8 @@ sits_config <- function(config_user_file = NULL) { .conf_load_color_table() # set the user options .conf_set_user_file(config_user_file) - # set the fonts - .conf_set_fonts() + # set the fonts - disable because of problems using DEAfrica + # .conf_set_fonts() # return configuration return(invisible(sits_env$config)) } diff --git a/R/sits_cube.R b/R/sits_cube.R index d3b5096b6..b3fc5a69b 100755 --- a/R/sits_cube.R +++ b/R/sits_cube.R @@ -247,7 +247,7 @@ #' #' ## Sentinel-1 SAR from MPC #' roi_sar <- c("lon_min" = -50.410, "lon_max" = -50.379, -#' "lat_min" = -10.1910, "lat_max" = -10.1573) +#' "lat_min" = -10.1910, "lat_max" = -10.1573) #' #' s1_cube_open <- sits_cube( #' source = "MPC", @@ -256,7 +256,7 @@ #' roi = roi_sar, #' start_date = "2020-06-01", #' end_date = "2020-09-28" -#' ) +#' ) #' #' # --- Create a cube based on a local MODIS data #' data_dir <- system.file("extdata/raster/mod13q1", package = "sits") diff --git a/R/sits_cube_copy.R b/R/sits_cube_copy.R index 015c1a164..dd0b62280 100644 --- a/R/sits_cube_copy.R +++ b/R/sits_cube_copy.R @@ -59,7 +59,7 @@ sits_cube_copy <- function(cube, progress = TRUE) { # Pre-conditions .check_is_raster_cube(cube) - .check_cube_files(cube) + .check_raster_cube_files(cube) if (.has(roi)) { sf_roi <- .roi_as_sf(roi, default_crs = cube$crs[[1]]) } else { diff --git a/R/sits_get_data.R b/R/sits_get_data.R index 825743acc..165ab7fa0 100644 --- a/R/sits_get_data.R +++ b/R/sits_get_data.R @@ -111,7 +111,7 @@ sits_get_data <- function(cube, # Pre-conditions .check_is_raster_cube(cube) .check_is_regular(cube) - .check_cube_files(cube) + .check_raster_cube_files(cube) .check_cube_bands(cube, bands = bands) .check_crs(crs) .check_multicores(multicores, min = 1, max = 2048) diff --git a/R/sits_label_classification.R b/R/sits_label_classification.R index bbc83fed9..b8cf2741a 100644 --- a/R/sits_label_classification.R +++ b/R/sits_label_classification.R @@ -9,11 +9,6 @@ #' #' @param cube Classified image data cube. #' @param ... Other parameters for specific functions. -#' @param clean A logical value to apply a modal function to clean up -#' possible noisy pixels keeping the most frequently -#' values within the neighborhood. Default is TRUE. -#' @param window_size An odd integer representing the size of the -#' sliding window of the modal function (min = 1, max = 15). #' @param multicores Number of workers to label the classification in #' parallel. #' @param memsize maximum overall memory (in GB) to label the @@ -58,10 +53,8 @@ #' } #' @export sits_label_classification <- function(cube, - clean = TRUE, - window_size = 3L, - memsize = 4, - multicores = 2, + memsize = 4L, + multicores = 2L, output_dir, version = "v1", progress = TRUE) { @@ -72,17 +65,13 @@ sits_label_classification <- function(cube, #' @rdname sits_label_classification #' @export sits_label_classification.probs_cube <- function(cube, ..., - clean = TRUE, - window_size = 3L, memsize = 4L, multicores = 2L, output_dir, version = "v1", progress = TRUE) { # Pre-conditions - Check parameters - .check_cube_files(cube) - .check_lgl_parameter(clean) - .check_window_size(window_size = window_size, min = 3, max = 15) + .check_raster_cube_files(cube) .check_memsize(memsize, min = 1, max = 16384) .check_multicores(multicores, min = 1, max = 2048) .check_output_dir(output_dir) @@ -92,10 +81,6 @@ sits_label_classification.probs_cube <- function(cube, ..., # Get block size block <- .raster_file_blocksize(.raster_open_rast(.tile_path(cube))) - # Get image size - image_size <- .raster_size(.raster_open_rast(.tile_path(cube))) - # Overlapping pixels - overlap <- ceiling(window_size / 2) - 1 # Check minimum memory needed to process one block job_memsize <- .jobs_memsize( job_size = .block_size(block = block, overlap = 0), @@ -120,24 +105,6 @@ sits_label_classification.probs_cube <- function(cube, ..., label_fn <- .label_fn_majority() # Process each tile sequentially class_cube <- .cube_foreach_tile(cube, function(tile) { - # Output file - out_file <- .file_derived_name( - tile = tile, band = "class", version = version, - output_dir = output_dir - ) - # Resume feature - if (file.exists(out_file)) { - .check_recovery(tile[["tile"]]) - class_tile <- .tile_derived_from_file( - file = out_file, - band = "class", - base_tile = tile, - derived_class = "class_cube", - labels = .tile_labels(tile), - update_bbox = FALSE - ) - return(class_tile) - } # Label the data class_tile <- .label_tile( tile = tile, @@ -147,18 +114,6 @@ sits_label_classification.probs_cube <- function(cube, ..., version = version, progress = progress ) - if (clean) { - # Apply clean in data - class_tile <- .clean_tile( - tile = class_tile, - block = image_size, - band = "class", - window_size = window_size, - overlap = overlap, - output_dir = output_dir, - version = version - ) - } return(class_tile) }) return(class_cube) @@ -171,7 +126,7 @@ sits_label_classification.probs_vector_cube <- function(cube, ..., version = "v1", progress = TRUE) { # Pre-conditions - Check parameters - .check_cube_files(cube) + .check_raster_cube_files(cube) .check_output_dir(output_dir) version <- .check_version(version) # version is case-insensitive in sits diff --git a/R/sits_lighttae.R b/R/sits_lighttae.R index dd5245430..f1b95415c 100644 --- a/R/sits_lighttae.R +++ b/R/sits_lighttae.R @@ -181,7 +181,7 @@ sits_lighttae <- function(samples = NULL, timeline = timeline, bands = bands ) # Test samples are extracted from validation data - test_samples <- .predictors(samples) + test_samples <- .predictors(samples_validation) test_samples <- .pred_normalize( pred = test_samples, stats = ml_stats ) diff --git a/R/sits_machine_learning.R b/R/sits_machine_learning.R index 28c1068a9..162ba9f89 100644 --- a/R/sits_machine_learning.R +++ b/R/sits_machine_learning.R @@ -255,6 +255,7 @@ sits_svm <- function(samples = NULL, formula = sits_formula_linear(), #' @param nfold Number of the subsamples for the cross-validation. #' @param nrounds Number of rounds to iterate the cross-validation #' (default: 100) +#' @param nthread Number of threads (default = 6) #' @param early_stopping_rounds Training with a validation set will stop #' if the performance doesn't improve for k rounds. #' @param verbose Print information on statistics during the process @@ -284,6 +285,7 @@ sits_xgboost <- function(samples = NULL, learning_rate = 0.15, min_split_loss = 1, max_depth = 5, min_child_weight = 1, max_delta_step = 1, subsample = 0.8, nfold = 5, nrounds = 100, + nthread = 6, early_stopping_rounds = 20, verbose = FALSE) { # Function that trains a xgb model train_fun <- function(samples) { @@ -307,13 +309,21 @@ sits_xgboost <- function(samples = NULL, learning_rate = 0.15, eval_metric = "mlogloss", eta = learning_rate, gamma = min_split_loss, max_depth = max_depth, min_child_weight = min_child_weight, - max_delta_step = max_delta_step, subsample = subsample + max_delta_step = max_delta_step, subsample = subsample, + nthread = nthread ) - # Train a xgboost model - model <- xgboost::xgboost( + if (verbose) + verbose = 1 + else + verbose = 0 + # transform predictors in a xgb.DMatrix + xgb_matrix <- xgboost::xgb.DMatrix( data = as.matrix(.pred_features(train_samples)), - label = references, num_class = length(labels), params = params, - nrounds = nrounds, verbose = FALSE + label = references) + # train the model + model <- xgboost::xgb.train(xgb_matrix, + num_class = length(labels), params = params, + nrounds = nrounds, verbose = verbose ) # Get best ntreelimit ntreelimit <- model$best_ntreelimit diff --git a/R/sits_mlp.R b/R/sits_mlp.R index 36c97b10a..d20ae8da7 100644 --- a/R/sits_mlp.R +++ b/R/sits_mlp.R @@ -171,7 +171,7 @@ sits_mlp <- function(samples = NULL, timeline = timeline, bands = bands ) # Test samples are extracted from validation data - test_samples <- .predictors(samples) + test_samples <- .predictors(samples_validation) test_samples <- .pred_normalize( pred = test_samples, stats = ml_stats ) diff --git a/R/sits_plot.R b/R/sits_plot.R index 90bf4e9c1..13cb055ab 100644 --- a/R/sits_plot.R +++ b/R/sits_plot.R @@ -322,9 +322,9 @@ plot.predicted <- function(x, y, ..., #' @param date Date to be plotted. #' @param palette An RColorBrewer palette #' @param rev Reverse the color order in the palette? -#' @param tmap_options List with optional tmap parameters +#' @param tmap_options Named list with optional tmap parameters #' max_cells (default: 1e+06) -#' scale (default: 0.5) +#' scale (default: 1.0) #' graticules_labels_size (default: 0.7) #' legend_title_size (default: 1.0) #' legend_text_size (default: 1.0) @@ -452,13 +452,14 @@ plot.raster_cube <- function(x, ..., #' @param line_width Line width to plot the segments boundary (in pixels) #' @param palette An RColorBrewer palette #' @param rev Reverse the color order in the palette? -#' @param tmap_options List with optional tmap parameters -#' tmap_max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) +#' @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 object with an RGB image #' or a B/W image on a color @@ -582,13 +583,14 @@ plot.vector_cube <- function(x, ..., #' @param labels Labels to plot (optional). #' @param palette RColorBrewer palette #' @param rev Reverse order of colors in palette? -#' @param tmap_options List with optional tmap parameters -#' tmap_max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) +#' @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. #' @@ -617,7 +619,7 @@ plot.vector_cube <- function(x, ..., plot.probs_cube <- function(x, ..., tile = x$tile[[1]], labels = NULL, - palette = "YlGnBu", + palette = "YlGn", rev = FALSE, tmap_options = NULL) { # check for color_palette parameter (sits 1.4.1) @@ -655,13 +657,14 @@ plot.probs_cube <- function(x, ..., #' @param labels Labels to plot (optional). #' @param palette RColorBrewer palette #' @param rev Reverse order of colors in palette? -#' @param tmap_options List with optional tmap parameters -#' tmap_max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) +#' @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. #' @@ -704,7 +707,7 @@ plot.probs_cube <- function(x, ..., plot.probs_vector_cube <- function(x, ..., tile = x$tile[[1]], labels = NULL, - palette = "YlGnBu", + palette = "YlGn", rev = FALSE, tmap_options = NULL) { # check for color_palette parameter (sits 1.4.1) @@ -747,13 +750,14 @@ plot.probs_vector_cube <- function(x, ..., #' @param palette RColorBrewer palette #' @param rev Reverse order of colors in palette? #' @param type Type of plot ("map" or "hist") -#' @param tmap_options List with optional tmap parameters -#' tmap_max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) +#' @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. #' @@ -830,13 +834,14 @@ plot.variance_cube <- function(x, ..., #' @param tile Tiles to be plotted. #' @param palette An RColorBrewer palette #' @param rev Reverse the color order in the palette? -#' @param tmap_options List with optional tmap parameters -#' tmap_max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) +#' @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 object produced by the stars package #' with a map showing the uncertainty associated @@ -900,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 = TRUE, + 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} @@ -912,18 +1012,14 @@ plot.uncertainty_cube <- function(x, ..., #' @param title Title of the plot. #' @param legend Named vector that associates labels to colors. #' @param palette Alternative RColorBrewer palette -#' @param tmap_options List with optional tmap parameters +#' @param tmap_options Named list with optional tmap parameters #' max_cells (default: 1e+06) +#' scale (default: 0.5) #' graticules_labels_size (default: 0.7) -#' scale (default = 0.8) -#' legend_title_size (default: 0.7) -#' legend_text_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) -#' legend_width (default: 0.5) -#' legend_height (default: 0.7) -#' legend_position (default: c("left", "bottom")) -#' #' #' @return A color map, where each pixel has the color #' associated to a label, as defined by the legend @@ -1016,13 +1112,14 @@ plot.class_cube <- function(x, y, ..., #' @param seg_color Segment color. #' @param line_width Segment line width. #' @param palette Alternative RColorBrewer palette -#' @param tmap_options List with optional tmap parameters -#' tmap_max_cells (default: 1e+06) -#' tmap_graticules_labels_size (default: 0.7) -#' tmap_legend_title_size (default: 1.5) -#' tmap_legend_text_size (default: 1.2) -#' tmap_legend_bg_color (default: "white") -#' tmap_legend_bg_alpha (default: 0.5) +#' @param tmap_options Named list with optional tmap parameters +#' max_cells (default: 1e+06) +#' scale (default: 0.5) +#' 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 object with an RGB image #' or a B/W image on a color @@ -1362,13 +1459,15 @@ plot.som_map <- function(x, y, ..., type = "codes", band = 1) { #' @name plot.xgb_model #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} #' -#' @description Plots the important variables in an extreme gradient boosting. +#' @description Plots trees in an extreme gradient boosting model. #' #' #' @param x Object of class "xgb_model". #' @param ... Further specifications for \link{plot}. -#' @param n_trees Number of trees to be plotted -#' @return A plot object. +#' @param trees Vector of trees to be plotted +#' @param width Width of the output window +#' @param height Height of the output window +#' @return A plot #' #' @note #' Please refer to the sits documentation available in @@ -1380,17 +1479,20 @@ plot.som_map <- function(x, y, ..., type = "codes", band = 1) { #' xgb_model <- sits_train(samples_modis_ndvi, #' ml_method = sits_xgboost() #' ) +#' plot(xgb_model) #' } #' @export #' -plot.xgb_model <- function(x, ..., n_trees = 3) { +plot.xgb_model <- function(x, ..., + trees = c(0:4), width = 1500, height = 1900) { # verifies if DiagrammeR package is installed .check_require_packages("DiagrammeR") .check_is_sits_model(x) - # retrieve the XGB object from the enviroment + # retrieve the XGB object from the environment xgb <- .ml_model(x) # plot the trees - p <- xgboost::xgb.plot.tree(model = xgb, trees = seq_len(n_trees) - 1) + gr <- xgboost::xgb.plot.tree(model = xgb, trees = trees, render = FALSE) + p <- DiagrammeR::render_graph(gr, width = width, height = height) return(p) } #' @title Plot Torch (deep learning) model diff --git a/R/sits_reclassify.R b/R/sits_reclassify.R index 0b635de5a..0e8b59293 100644 --- a/R/sits_reclassify.R +++ b/R/sits_reclassify.R @@ -117,13 +117,13 @@ sits_reclassify <- function(cube, .check_valid(mask) # check cube .check_cube_is_class_cube(cube) - .check_cube_files(cube) + .check_raster_cube_files(cube) # # check mask .check_that( x = inherits(mask, "class_cube"), msg = "mask is not a classified data cube" ) - .check_cube_files(mask) + .check_raster_cube_files(mask) UseMethod("sits_reclassify", cube) } diff --git a/R/sits_regularize.R b/R/sits_regularize.R index 590dcb319..c647c3444 100644 --- a/R/sits_regularize.R +++ b/R/sits_regularize.R @@ -113,7 +113,7 @@ sits_regularize.raster_cube <- function(cube, multicores = 2L, progress = TRUE) { # Preconditions - .check_cube_files(cube) + .check_raster_cube_files(cube) .period_check(period) .check_num_parameter(res, exclusive_min = 0) output_dir <- .file_normalize(output_dir) @@ -165,7 +165,7 @@ sits_regularize.raster_cube <- function(cube, multicores = 2L, progress = TRUE) { # Preconditions - .check_cube_files(cube) + .check_raster_cube_files(cube) .period_check(period) .check_num_parameter(res, exclusive_min = 0) output_dir <- .file_normalize(output_dir) diff --git a/R/sits_resnet.R b/R/sits_resnet.R index 39ea02ef6..c899aa521 100644 --- a/R/sits_resnet.R +++ b/R/sits_resnet.R @@ -195,7 +195,7 @@ sits_resnet <- function(samples = NULL, timeline = timeline, bands = bands ) # Test samples are extracted from validation data - test_samples <- .predictors(samples) + test_samples <- .predictors(samples_validation) test_samples <- .pred_normalize( pred = test_samples, stats = ml_stats ) diff --git a/R/sits_sample_functions.R b/R/sits_sample_functions.R index b494a72bb..40342d410 100644 --- a/R/sits_sample_functions.R +++ b/R/sits_sample_functions.R @@ -234,3 +234,135 @@ sits_reduce_imbalance <- function(samples, # return new sample set return(new_samples[, colnames_sits]) } +#' @title Allocation of sample size to strata +#' @name sits_sampling_design +#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br} +#' +#' @description +#' Takes a class cube with different labels and allocates a number of +#' sample sizes per strata to obtain suitable values of error-adjusted area, +#' providing five allocation strategies. +#' +#' @param cube Classified cube +#' @param expected_ua Expected values of user's accuracy +#' @param std_err Standard error we would like to achieve +#' @param rare_class_prop Proportional area limit for rare classes +#' +#' +#' @return A matrix with options to decide allocation +#' of sample size to each class. This matrix uses the same format as +#' Table 5 of Olofsson et al.(2014). +#' +#' @references +#' [1] Olofsson, P., Foody, G.M., Stehman, S.V., Woodcock, C.E. (2013). +#' Making better use of accuracy data in land change studies: Estimating +#' accuracy and area and quantifying uncertainty using stratified estimation. +#' Remote Sensing of Environment, 129, pp.122-131. +#' +#' @references +#' [2] Olofsson, P., Foody G.M., Herold M., Stehman, S.V., +#' Woodcock, C.E., Wulder, M.A. (2014) +#' Good practices for estimating area and assessing accuracy of land change. +#' Remote Sensing of Environment, 148, pp. 42-57. +#' +#' @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 +#' ) +#' # classify a data cube +#' probs_cube <- sits_classify( +#' data = cube, ml_model = rfor_model, output_dir = tempdir() +#' ) +#' # label the probability cube +#' label_cube <- sits_label_classification( +#' probs_cube, +#' output_dir = tempdir() +#' ) +#' # estimated UA for classes +#' expected_ua <- c(Cerrado = 0.75, Forest = 0.9, +#' Pasture = 0.8, Soy_Corn = 0.8) +#' sampling_design <- sits_sampling_design(label_cube, expected_ua) +#' } +#' @export +sits_sampling_design <- function(cube, + expected_ua = 0.75, + std_err = 0.01, + rare_class_prop = 0.1){ + # check the cube is valid + .check_raster_cube_files(cube) + # check cube is class cube + .check_cube_is_class_cube(cube) + # get the labels + labels <- .cube_labels(cube) + n_labels <- length(labels) + if (length(expected_ua) == 1 ) { + expected_ua <- rep(expected_ua, n_labels) + names(expected_ua) = labels + } + # check number of labels + .check_that(length(expected_ua) == n_labels, + msg = "Expected values of user's accuracy + should match number of labels" + ) + # check names of labels + .check_that(all(labels %in% names(expected_ua)), + msg = "Expected values of user's accuracy + should contain names of labels" + ) + # adjust names to match cube labels + expected_ua <- expected_ua[labels] + # get cube class areas + class_areas <- .cube_class_areas(cube) + # calculate proportion of class areas + prop <- class_areas / sum(class_areas) + # standard deviation of the stratum + std_dev <- signif(sqrt(expected_ua * (1 - expected_ua)), 3) + # calculate sample size + sample_size <- round((sum(prop * std_dev)/std_err)^2) + # determine "Equal" allocation + equal <- rep(round(sample_size/n_labels), n_labels) + names(equal) <- labels + # find out the classes which are rare + rare_classes <- prop[prop <= rare_class_prop] + # Determine allocation possibilities + # allocate a sample size of 50–100 for rare classes + # Given each allocation for rare classes (e.g, 100 samples) + # allocate the rest of the sample size proportionally + # to the other more frequent classes + alloc_three <- c(100, 75, 50) + alloc_options.lst <- purrr::map(alloc_three, function(al){ + # determine the number of samples to be allocated + # to more frequent classes + samples_rare_classes <- al * length(rare_classes) + remaining_samples <- sample_size - samples_rare_classes + # allocate samples per class + # rare classes are given a fixed value (100, 75, 50) + # other classes are allocated proportionally to area + alloc_class.lst <- purrr::map(prop, function(p) { + if (p <= rare_class_prop) { + choice <- al + } else { + choice_prop <- p / (1.0 - sum(rare_classes)) + choice <- round(choice_prop * remaining_samples) + } + return(choice) + }) + alloc_class <- cbind(alloc_class.lst) + colnames(alloc_class) <- paste0("alloc_", al) + return(alloc_class) + }) + # get the three allocation options + alloc_options <- do.call(cbind,alloc_options.lst) + # final option is the proportional allocation + alloc_prop <- round(prop * sample_size) + # put it all together + design <- cbind(prop, expected_ua, std_dev, equal, alloc_options, alloc_prop) + return(design) +} 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/R/sits_select.R b/R/sits_select.R index d01d5e2ce..0ec93dafe 100644 --- a/R/sits_select.R +++ b/R/sits_select.R @@ -88,7 +88,7 @@ sits_select.raster_cube <- function(data, dates = NULL, tiles = NULL) { # Pre-condition - .check_cube_files(data) + .check_raster_cube_files(data) # Filter bands if (!purrr::is_null(bands) && !any(is.na(bands))) { bands <- .band_set_case(bands) diff --git a/R/sits_smooth.R b/R/sits_smooth.R index d594ae124..8ef350bb0 100644 --- a/R/sits_smooth.R +++ b/R/sits_smooth.R @@ -63,7 +63,7 @@ sits_smooth <- function(cube, window_size = 7L, neigh_fraction = 0.5, smoothness = 10L, memsize = 4L, multicores = 2L, output_dir, version = "v1") { # Check if cube has probability data - .check_cube_files(cube) + .check_raster_cube_files(cube) # check window size .check_window_size(window_size, min = 3, max = 33) # check neighborhood fraction diff --git a/R/sits_tae.R b/R/sits_tae.R index 08201ab95..f38850110 100644 --- a/R/sits_tae.R +++ b/R/sits_tae.R @@ -166,7 +166,7 @@ sits_tae <- function(samples = NULL, timeline = timeline, bands = bands ) # Test samples are extracted from validation data - test_samples <- .predictors(samples) + test_samples <- .predictors(samples_validation) test_samples <- .pred_normalize( pred = test_samples, stats = ml_stats ) diff --git a/R/sits_tempcnn.R b/R/sits_tempcnn.R index 76859b632..55a6dd072 100644 --- a/R/sits_tempcnn.R +++ b/R/sits_tempcnn.R @@ -184,7 +184,7 @@ sits_tempcnn <- function(samples = NULL, timeline = timeline, bands = bands ) # Test samples are extracted from validation data - test_samples <- .predictors(samples) + test_samples <- .predictors(samples_validation) test_samples <- .pred_normalize( pred = test_samples, stats = ml_stats ) diff --git a/R/sits_uncertainty.R b/R/sits_uncertainty.R index 301eb4de4..1505e446b 100644 --- a/R/sits_uncertainty.R +++ b/R/sits_uncertainty.R @@ -7,6 +7,7 @@ #' @author Alber Sanchez, \email{alber.ipia@@inpe.br} #' #' @param cube Probability data cube. +#' @param ... Other parameters for specific functions. #' @param type Method to measure uncertainty. See details. #' @param multicores Number of cores to run the function. #' @param memsize Maximum overall memory (in GB) to run the function. @@ -51,16 +52,26 @@ #' plot(uncert_cube) #' } #' @export -sits_uncertainty <- function( - cube, +sits_uncertainty <- function(cube, ..., + type = "entropy", + multicores = 2L, + memsize = 4L, + output_dir, + version = "v1") { + # Dispatch + UseMethod("sits_uncertainty", cube) +} +#' @rdname sits_uncertainty +#' @export +sits_uncertainty.probs_cube <- function( + cube, ..., type = "entropy", multicores = 2, memsize = 4, output_dir, version = "v1") { # Check if cube has probability data - .check_cube_files(cube) - .check_cube_is_probs_cube(cube) + .check_raster_cube_files(cube) # Check memsize .check_memsize(memsize, min = 1, max = 16384) # Check multicores @@ -91,24 +102,17 @@ sits_uncertainty <- function( .parallel_start(workers = multicores) on.exit(.parallel_stop(), add = TRUE) # Define the class of the smoothing - class(type) <- c(type, class(type)) - UseMethod("sits_uncertainty", type) -} - -#' @rdname sits_uncertainty -#' @export -sits_uncertainty.least <- function( - cube, - type = "least", - multicores = 2, - memsize = 4, - output_dir, - version = "v1") { + uncert_fn <- switch( + type, + "least" = .uncertainty_fn_least(), + "margin" = .uncertainty_fn_margin(), + "entropy" = .uncertainty_fn_entropy() + ) # Compute uncertainty - uncert_cube <- .uncertainty_cube( + uncert_cube <- .uncertainty_raster_cube( cube = cube, - band = "least", - uncert_fn = .uncertainty_fn_least(), + band = type, + uncert_fn = uncert_fn, output_dir = output_dir, version = version ) @@ -116,38 +120,29 @@ sits_uncertainty.least <- function( } #' @rdname sits_uncertainty #' @export -sits_uncertainty.entropy <- function( - cube, +sits_uncertainty.probs_vector_cube <- function( + cube, ..., type = "entropy", multicores = 2, memsize = 4, output_dir, version = "v1") { + # Check if cube has probability data + .check_raster_cube_files(cube) + # Check memsize + .check_memsize(memsize, min = 1, max = 16384) + # Check multicores + .check_multicores(multicores, min = 1, max = 2048) + # check output dir + .check_output_dir(output_dir) + # check version + version <- .check_version(version) + # version is case-insensitive in sits + version <- tolower(version) # Compute uncertainty - uncert_cube <- .uncertainty_cube( - cube = cube, - band = "entropy", - uncert_fn = .uncertainty_fn_entropy(), - output_dir = output_dir, - version = version - ) - return(uncert_cube) -} - -#' @rdname sits_uncertainty -#' @export -sits_uncertainty.margin <- function( - cube, - type = "margin", - multicores = 2, - memsize = 4, - output_dir, - version = "v1") { - # Create uncertainty cube - uncert_cube <- .uncertainty_cube( + uncert_cube <- .uncertainty_vector_cube( cube = cube, - band = "margin", - uncert_fn = .uncertainty_fn_margin(), + band = type, output_dir = output_dir, version = version ) @@ -156,7 +151,7 @@ sits_uncertainty.margin <- function( #' @rdname sits_uncertainty #' @export sits_uncertainty.default <- function( - cube, + cube, ..., type, multicores, memsize, diff --git a/R/sits_validate.R b/R/sits_validate.R index 67b13382a..74872958c 100644 --- a/R/sits_validate.R +++ b/R/sits_validate.R @@ -229,4 +229,5 @@ sits_validate <- function(samples, acc_obj <- caret::confusionMatrix(predicted, reference) # Set result class and return it .set_class(x = acc_obj, "sits_accuracy", class(acc_obj)) + return(acc_obj) } diff --git a/R/sits_variance.R b/R/sits_variance.R index 8ac0e4a4a..f308c17ef 100644 --- a/R/sits_variance.R +++ b/R/sits_variance.R @@ -57,7 +57,7 @@ sits_variance <- function( output_dir, version = "v1") { # Check if cube has data and metadata - .check_cube_files(cube) + .check_raster_cube_files(cube) # check window size .check_window_size(window_size, min = 3, max = 33) # check neighborhood fraction diff --git a/R/sits_view.R b/R/sits_view.R index bca6bf29a..1b78a7c04 100644 --- a/R/sits_view.R +++ b/R/sits_view.R @@ -362,14 +362,7 @@ sits_view.class_cube <- function(x, ..., palette = palette, opacity = opacity, output_size = output_size - ) |> - # add legend - .view_add_legend( - cube = cube, - legend = legend, - palette = palette ) - # add overlay groups overlay_groups <- .view_add_overlay_grps( cube = cube @@ -380,7 +373,14 @@ sits_view.class_cube <- function(x, ..., baseGroups = base_maps, overlayGroups = overlay_groups, options = leaflet::layersControlOptions(collapsed = FALSE) + ) |> + # add legend + .view_add_legend( + cube = cube, + legend = legend, + palette = palette ) + return(leaf_map) } #' @rdname sits_view diff --git a/R/sits_xlsx.R b/R/sits_xlsx.R index 2be53e75d..8f378a4f5 100644 --- a/R/sits_xlsx.R +++ b/R/sits_xlsx.R @@ -7,9 +7,9 @@ #' by \code{\link[sits]{sits_accuracy}} #' and saves them in an Excel spreadsheet. #' -#' @param acc_lst A list of accuracy statistics +#' @param acc Accuracy statistics (either an output of sits_accuracy +#' or a list of those) #' @param file The file where the XLSX data is to be saved. -#' @param data (optional) Print information about the samples #' #' @return No return value, called for side effects. #' @@ -43,7 +43,21 @@ #' } #' @export #' -sits_to_xlsx <- function(acc_lst, file, data = NULL) { +#' +sits_to_xlsx <- function(acc, file) { + UseMethod("sits_to_xlsx", acc) +} +#' @rdname sits_to_xlsx +#' @export +#' +sits_to_xlsx.sits_accuracy <- function(acc, file) { + acc_lst <- list(acc) + sits_to_xlsx(acc_lst, file) +} +#' @rdname sits_to_xlsx +#' @export +#' +sits_to_xlsx.list <- function(acc, file) { # set caller to show in errors .check_set_caller("sits_to_xlsx") # create a workbook to save the results @@ -52,14 +66,14 @@ sits_to_xlsx <- function(acc_lst, file, data = NULL) { eo_n <- c("(Sensitivity)|(Specificity)| (Pos Pred Value)|(Neg Pred Value)|(F1)") # defined the number of sheets - num_sheets <- length(acc_lst) + num_sheets <- length(acc) .check_length( x = num_sheets, len_min = 1, msg = "number of sheets should be at least one" ) # save all elements of the list - purrr::map2(acc_lst, 1:num_sheets, function(cf_mat, ind) { + purrr::map2(acc, 1:num_sheets, function(cf_mat, ind) { # create a worksheet for each confusion matrix if (purrr::is_null(cf_mat$name)) { cf_mat$name <- paste0("sheet", ind) diff --git a/README.Rmd b/README.Rmd index 065c78580..82ea71aa8 100644 --- a/README.Rmd +++ b/README.Rmd @@ -61,13 +61,16 @@ Detailed documentation on how to use `sits` is available in the e-book ["Satelli Those that want to evaluate the `sits` package before installing are invited to run the examples available on [Kaggle](https://www.kaggle.com/esensing/code). If you are new on kaggle, please follow the [instructions](https://gist.github.com/OldLipe/814089cc5792c9c0c989d870a22910f4) to set up your account. These examples provide a fast-track introduction to the package. We recommend running them in the following order: -1. [Introduction to SITS](https://www.kaggle.com/esensing/introduction-to-sits) -2. [Working with time series in SITS](https://www.kaggle.com/esensing/working-with-time-series-in-sits) -3. [Creating data cubes in SITS](https://www.kaggle.com/esensing/creating-data-cubes-in-sits) -4. [Machine learning for data cubes](https://www.kaggle.com/esensing/machine-learning-for-data-cubes) -5. [Raster classification in SITS](https://www.kaggle.com/esensing/raster-classification-in-sits) -6. [Object-based time series classification using GPU](https://www.kaggle.com/esensing/object-based-time-series-classification-using-gpu) -7. [Using SOM for sample quality control in SITS](https://www.kaggle.com/esensing/using-som-for-sample-quality-control-in-sits) +1. [Introduction to SITS](https://www.kaggle.com/esensing/introduction-to-sits) +2. [Working with time series in SITS](https://www.kaggle.com/esensing/working-with-time-series-in-sits) +3. [Creating data cubes in SITS](https://www.kaggle.com/esensing/creating-data-cubes-in-sits) +4. [Improving the quality of training samples](https://www.kaggle.com/code/esensing/improving-quality-of-training-samples) +5. [Machine learning for data cubes](https://www.kaggle.com/esensing/machine-learning-for-data-cubes) +6. [Classification of raster data cubes](https://www.kaggle.com/code/esensing/classification-of-raster-data-cubes) +7. [Bayesian smoothing for post-processing](https://www.kaggle.com/code/esensing/bayesian-smoothing-for-post-processing) +8. [Uncertainty and active learning](https://www.kaggle.com/code/esensing/uncertainty-and-active-learning) +9. [Object-based time series classification](https://www.kaggle.com/esensing/object-based-image-time-series-classification) + ## Installation diff --git a/README.md b/README.md index daf5f2c8d..79d43eeaf 100644 --- a/README.md +++ b/README.md @@ -77,13 +77,18 @@ to the package. We recommend running them in the following order: SITS](https://www.kaggle.com/esensing/working-with-time-series-in-sits) 3. [Creating data cubes in SITS](https://www.kaggle.com/esensing/creating-data-cubes-in-sits) -4. [Improving the quality of training samples](https://www.kaggle.com/code/esensing/improving-quality-of-training-samples) +4. [Improving the quality of training + samples](https://www.kaggle.com/code/esensing/improving-quality-of-training-samples) 5. [Machine learning for data cubes](https://www.kaggle.com/esensing/machine-learning-for-data-cubes) -6. [Classification of raster data cubes](https://www.kaggle.com/code/esensing/classification-of-raster-data-cubes) -7. [Bayesian smoothing for post-processing](https://www.kaggle.com/code/esensing/bayesian-smoothing-for-post-processing) -8. [Uncertainty and active learning](https://www.kaggle.com/code/esensing/uncertainty-and-active-learning) -9. [Object-based time series classification](https://www.kaggle.com/esensing/object-based-image-time-series-classification) +6. [Classification of raster data + cubes](https://www.kaggle.com/code/esensing/classification-of-raster-data-cubes) +7. [Bayesian smoothing for + post-processing](https://www.kaggle.com/code/esensing/bayesian-smoothing-for-post-processing) +8. [Uncertainty and active + learning](https://www.kaggle.com/code/esensing/uncertainty-and-active-learning) +9. [Object-based time series + classification](https://www.kaggle.com/esensing/object-based-image-time-series-classification) ## Installation @@ -114,7 +119,7 @@ devtools::install_github("e-sensing/sits", dependencies = TRUE) # load the sits library library(sits) #> SITS - satellite image time series analysis. -#> Loaded sits v1.4.2. +#> Loaded sits v1.4.2-1. #> See ?sits for help, citation("sits") for use in publication. #> Documentation avaliable in https://e-sensing.github.io/sitsbook/. ``` @@ -132,8 +137,8 @@ more information on how to install the required drivers. ### Image Collections Accessible by `sits` Users create data cubes from analysis-ready data (ARD) image collections -available in cloud services. The collections accessible in `sits` 1.4.2 -are: +available in cloud services. The collections accessible in `sits` +1.4.2.1 are: 1. Brazil Data Cube ([BDC](http://brazildatacube.org/en/home-page-2/#dataproducts)): diff --git a/inst/extdata/accuracy/sample_size_stratified_simple_random.xlsx b/inst/extdata/accuracy/sample_size_stratified_simple_random.xlsx new file mode 100644 index 000000000..0e587f1fb Binary files /dev/null and b/inst/extdata/accuracy/sample_size_stratified_simple_random.xlsx differ diff --git a/inst/extdata/config_colors.yml b/inst/extdata/config_colors.yml index 0e716ea0b..9a259e259 100644 --- a/inst/extdata/config_colors.yml +++ b/inst/extdata/config_colors.yml @@ -6,9 +6,7 @@ # Colours partially adapted for Africa Standardized Terrestrial Ecosystems # and 1970 U.S. Vegetation Map # -class_schemes: - legends: ["IGBP", "UMD", "ESA_CCI_LC", "WORLDCOVER", "PRODES", - "PRODES_VISUAL", "TERRA_CLASS", "TERRA_CLASS_PT"] +legends: IGBP: [ "Evergreen_Broadleaf_Forests", "Deciduous_Broadleaf_Forests", "Evergreen_Needleleaf_Forests", "Deciduous_Needleleaf_Forests", diff --git a/inst/extdata/config_internals.yml b/inst/extdata/config_internals.yml index ecc126919..63c54cac6 100644 --- a/inst/extdata/config_internals.yml +++ b/inst/extdata/config_internals.yml @@ -247,11 +247,12 @@ tmap: legend_text_size: 1.0 legend_bg_color: "white" legend_bg_alpha: 0.5 - legend_width: 0.5 + legend_width: 1.0 legend_position: ["left", "bottom"] legend_height: 1.0 - scale: 0.5 + scale: 1.0 font_family: "plex_sans" + n_breaks: 20 # maxbytes for leaflet (in MB) leaflet_megabytes : 64 diff --git a/inst/extdata/config_user_example.yml b/inst/extdata/config_user_example.yml index a68e162de..5b4040280 100644 --- a/inst/extdata/config_user_example.yml +++ b/inst/extdata/config_user_example.yml @@ -2,9 +2,18 @@ processing_bloat : 8 rstac_pagination_limit : 100 gdal_creation_options : ["COMPRESS=LZW", "BIGTIFF=YES"] + +legends: + US_NLCD : ["Urban_Built_Up", "Agricultural_Land", + "Rangeland", "Forest_Land", "Water", "Wetland", + "Tundra", "Snow_and_Ice"] + colors: - Cropland: "khaki" - Deforestation: "sienna" - Forest : "darkgreen" - Grassland : "lightgreen" - NonForest: "lightsteelblue1" + Urban_Built_Up : "#85929E" + Agricultural_Land : "#F0B27A" + Rangeland : "#F1C40F" + Forest_Land : "#27AE60" + Water : "#2980B9" + Wetland : "#D4E6F1" + Tundra : "#EBDEF0" + Snow_and_Ice : "#F7F9F9" diff --git a/man/plot.class_cube.Rd b/man/plot.class_cube.Rd index 6fd553c51..62686766e 100644 --- a/man/plot.class_cube.Rd +++ b/man/plot.class_cube.Rd @@ -30,17 +30,14 @@ \item{palette}{Alternative RColorBrewer palette} -\item{tmap_options}{List with optional tmap parameters +\item{tmap_options}{Named list with optional tmap parameters max_cells (default: 1e+06) +scale (default: 0.5) graticules_labels_size (default: 0.7) -scale (default = 0.8) -legend_title_size (default: 0.7) -legend_text_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) -legend_width (default: 0.5) -legend_height (default: 0.7) -legend_position (default: c("left", "bottom"))} +legend_bg_alpha (default: 0.5)} } \value{ A color map, where each pixel has the color diff --git a/man/plot.class_vector_cube.Rd b/man/plot.class_vector_cube.Rd index 2b819dfe7..343d85e4c 100644 --- a/man/plot.class_vector_cube.Rd +++ b/man/plot.class_vector_cube.Rd @@ -30,13 +30,14 @@ \item{palette}{Alternative RColorBrewer palette} -\item{tmap_options}{List with optional tmap parameters -tmap_max_cells (default: 1e+06) -tmap_graticules_labels_size (default: 0.7) -tmap_legend_title_size (default: 1.5) -tmap_legend_text_size (default: 1.2) -tmap_legend_bg_color (default: "white") -tmap_legend_bg_alpha (default: 0.5)} +\item{tmap_options}{Named list with optional tmap parameters +max_cells (default: 1e+06) +scale (default: 0.5) +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 object with an RGB image diff --git a/man/plot.probs_cube.Rd b/man/plot.probs_cube.Rd index f4b7d36f8..a42626d70 100644 --- a/man/plot.probs_cube.Rd +++ b/man/plot.probs_cube.Rd @@ -9,7 +9,7 @@ ..., tile = x$tile[[1]], labels = NULL, - palette = "YlGnBu", + palette = "YlGn", rev = FALSE, tmap_options = NULL ) @@ -27,13 +27,14 @@ \item{rev}{Reverse order of colors in palette?} -\item{tmap_options}{List with optional tmap parameters -tmap_max_cells (default: 1e+06) -tmap_graticules_labels_size (default: 0.7) -tmap_legend_title_size (default: 1.5) -tmap_legend_text_size (default: 1.2) -tmap_legend_bg_color (default: "white") -tmap_legend_bg_alpha (default: 0.5)} +\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 diff --git a/man/plot.probs_vector_cube.Rd b/man/plot.probs_vector_cube.Rd index 5a0ac01b8..9fa7d4ac9 100644 --- a/man/plot.probs_vector_cube.Rd +++ b/man/plot.probs_vector_cube.Rd @@ -9,7 +9,7 @@ ..., tile = x$tile[[1]], labels = NULL, - palette = "YlGnBu", + palette = "YlGn", rev = FALSE, tmap_options = NULL ) @@ -27,13 +27,14 @@ \item{rev}{Reverse order of colors in palette?} -\item{tmap_options}{List with optional tmap parameters -tmap_max_cells (default: 1e+06) -tmap_graticules_labels_size (default: 0.7) -tmap_legend_title_size (default: 1.5) -tmap_legend_text_size (default: 1.2) -tmap_legend_bg_color (default: "white") -tmap_legend_bg_alpha (default: 0.5)} +\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 diff --git a/man/plot.raster_cube.Rd b/man/plot.raster_cube.Rd index f5ac2bc75..f34ca316a 100644 --- a/man/plot.raster_cube.Rd +++ b/man/plot.raster_cube.Rd @@ -39,9 +39,9 @@ \item{rev}{Reverse the color order in the palette?} -\item{tmap_options}{List with optional tmap parameters +\item{tmap_options}{Named list with optional tmap parameters max_cells (default: 1e+06) -scale (default: 0.5) +scale (default: 1.0) graticules_labels_size (default: 0.7) legend_title_size (default: 1.0) legend_text_size (default: 1.0) diff --git a/man/plot.uncertainty_cube.Rd b/man/plot.uncertainty_cube.Rd index e2e21536a..67e6e9a79 100644 --- a/man/plot.uncertainty_cube.Rd +++ b/man/plot.uncertainty_cube.Rd @@ -24,13 +24,14 @@ \item{rev}{Reverse the color order in the palette?} -\item{tmap_options}{List with optional tmap parameters -tmap_max_cells (default: 1e+06) -tmap_graticules_labels_size (default: 0.7) -tmap_legend_title_size (default: 1.5) -tmap_legend_text_size (default: 1.2) -tmap_legend_bg_color (default: "white") -tmap_legend_bg_alpha (default: 0.5)} +\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 object produced by the stars package diff --git a/man/plot.uncertainty_vector_cube.Rd b/man/plot.uncertainty_vector_cube.Rd new file mode 100644 index 000000000..f85e394b5 --- /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 = TRUE, + 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/plot.variance_cube.Rd b/man/plot.variance_cube.Rd index 9de0f6784..70b0785bd 100644 --- a/man/plot.variance_cube.Rd +++ b/man/plot.variance_cube.Rd @@ -30,13 +30,14 @@ \item{type}{Type of plot ("map" or "hist")} -\item{tmap_options}{List with optional tmap parameters -tmap_max_cells (default: 1e+06) -tmap_graticules_labels_size (default: 0.7) -tmap_legend_title_size (default: 1.5) -tmap_legend_text_size (default: 1.2) -tmap_legend_bg_color (default: "white") -tmap_legend_bg_alpha (default: 0.5)} +\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 diff --git a/man/plot.vector_cube.Rd b/man/plot.vector_cube.Rd index f4eb34f55..fd8bdb6cd 100644 --- a/man/plot.vector_cube.Rd +++ b/man/plot.vector_cube.Rd @@ -45,13 +45,14 @@ \item{rev}{Reverse the color order in the palette?} -\item{tmap_options}{List with optional tmap parameters -tmap_max_cells (default: 1e+06) -tmap_graticules_labels_size (default: 0.7) -tmap_legend_title_size (default: 1.5) -tmap_legend_text_size (default: 1.2) -tmap_legend_bg_color (default: "white") -tmap_legend_bg_alpha (default: 0.5)} +\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 object with an RGB image diff --git a/man/plot.xgb_model.Rd b/man/plot.xgb_model.Rd index b3dba6ca6..c5e0d3a80 100644 --- a/man/plot.xgb_model.Rd +++ b/man/plot.xgb_model.Rd @@ -4,20 +4,24 @@ \alias{plot.xgb_model} \title{Plot XGB model} \usage{ -\method{plot}{xgb_model}(x, ..., n_trees = 3) +\method{plot}{xgb_model}(x, ..., trees = c(0:4), width = 1500, height = 1900) } \arguments{ \item{x}{Object of class "xgb_model".} \item{...}{Further specifications for \link{plot}.} -\item{n_trees}{Number of trees to be plotted} +\item{trees}{Vector of trees to be plotted} + +\item{width}{Width of the output window} + +\item{height}{Height of the output window} } \value{ -A plot object. +A plot } \description{ -Plots the important variables in an extreme gradient boosting. +Plots trees in an extreme gradient boosting model. } \note{ Please refer to the sits documentation available in @@ -30,6 +34,7 @@ if (sits_run_examples()) { xgb_model <- sits_train(samples_modis_ndvi, ml_method = sits_xgboost() ) + plot(xgb_model) } } \author{ diff --git a/man/sits_classify.Rd b/man/sits_classify.Rd index 40012d948..7ec3ee38c 100644 --- a/man/sits_classify.Rd +++ b/man/sits_classify.Rd @@ -62,7 +62,7 @@ sits_classify( gpu_memory = 16, output_dir, version = "v1", - n_sam_pol = 40, + n_sam_pol = NULL, verbose = FALSE, progress = TRUE ) @@ -215,9 +215,8 @@ if (sits_run_examples()) { data = segments, ml_model = rf_model, output_dir = tempdir(), - n_sam_pol = 20, multicores = 4, - version = "segs_classify" + version = "segs" ) # Create a labelled vector cube class_segs <- sits_label_classification( diff --git a/man/sits_clean.Rd b/man/sits_clean.Rd new file mode 100644 index 000000000..56b0f7b90 --- /dev/null +++ b/man/sits_clean.Rd @@ -0,0 +1,133 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_clean.R +\name{sits_clean} +\alias{sits_clean} +\alias{sits_clean.class_cube} +\alias{sits_clean.raster_cube} +\alias{sits_clean.derived_cube} +\alias{sits_clean.tbl_df} +\alias{sits_clean.default} +\title{Cleans a classified map using a local window} +\usage{ +sits_clean( + cube, + window_size = 5L, + memsize = 4L, + multicores = 2L, + output_dir, + version = "v1-clean", + progress = TRUE +) + +\method{sits_clean}{class_cube}( + cube, + window_size = 5L, + memsize = 4L, + multicores = 2L, + output_dir, + version = "v1-clean", + progress = TRUE +) + +\method{sits_clean}{raster_cube}( + cube, + window_size = 5L, + memsize = 4L, + multicores = 2L, + output_dir, + version = "v1-clean", + progress = TRUE +) + +\method{sits_clean}{derived_cube}( + cube, + window_size = 5L, + memsize = 4L, + multicores = 2L, + output_dir, + version = "v1-clean", + progress = TRUE +) + +\method{sits_clean}{tbl_df}( + cube, + window_size = 5L, + memsize = 4L, + multicores = 2L, + output_dir, + version = "v1-clean", + progress = TRUE +) + +\method{sits_clean}{default}( + cube, + window_size = 5L, + memsize = 4L, + multicores = 2L, + output_dir, + version = "v1-clean", + progress = TRUE +) +} +\arguments{ +\item{cube}{Classified data cube (tibble of class "class_cube").} + +\item{window_size}{An odd integer representing the size of the +sliding window of the modal function (min = 1, max = 15).} + +\item{memsize}{Memory available for classification in GB +(integer, min = 1, max = 16384).} + +\item{multicores}{Number of cores to be used for classification +(integer, min = 1, max = 2048).} + +\item{output_dir}{Valid directory for output file. +(character vector of length 1).} + +\item{version}{Version of the output file +(character vector of length 1)} + +\item{progress}{Logical: Show progress bar?} +} +\value{ +A tibble with an classified map (class = "class_cube"). +} +\description{ +Applies a modal function to clean up possible noisy pixels keeping +the most frequently values within the neighborhood. +In a tie, the first value of the vector is considered. +} +\examples{ +if (sits_run_examples()) { +rf_model <- sits_train(samples_modis_ndvi, ml_method = 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 +) +# classify a data cube +probs_cube <- sits_classify( + data = cube, + ml_model = rf_model, + output_dir = tempdir() +) +# label the probability cube +label_cube <- sits_label_classification( + probs_cube, + output_dir = tempdir() +) +# apply a mode function in the labelled cube +clean_cube <- sits_clean( + cube = label_cube, + window_size = 5, + output_dir = tempdir(), + multicores = 1 +) +} + +} +\author{ +Felipe Carvalho, \email{felipe.carvalho@inpe.br} +} diff --git a/man/sits_colors_set.Rd b/man/sits_colors_set.Rd index 8efb43c2f..fa02e2686 100644 --- a/man/sits_colors_set.Rd +++ b/man/sits_colors_set.Rd @@ -4,37 +4,66 @@ \alias{sits_colors_set} \title{Function to set sits color table} \usage{ -sits_colors_set(color_tb) +sits_colors_set(colors, legend = NULL) } \arguments{ -\item{color_tb}{New color table} +\item{colors}{New color table (a tibble or data.frame with name and HEX code)} + +\item{legend}{Legend associated to the color table (optional)} } \value{ -A modified sits color table +A modified sits color table (invisible) } \description{ -Sets a color table +Includes new colors in the SITS color sets. If the colors exist, + replace them with the new HEX value. Optionally, the new colors + can be associated to a legend. In this case, the new legend + name should be informed. + The colors parameter should be a data.frame or a tibble + with name and HEX code. Colour names should be one character + string only. Composite names need to be combined with + underscores (e.g., use "Snow_and_Ice" instead of "Snow and Ice"). + + This function changes the global sits color table and the + global set of sits color legends. To undo these effects, + please use "sits_colors_reset()". } \examples{ if (sits_run_examples()) { # Define a color table based on the Anderson Land Classification System us_nlcd <- tibble::tibble(name = character(), color = character()) us_nlcd <- us_nlcd |> - tibble::add_row(name = "Urban Built Up", color = "#85929E") |> - tibble::add_row(name = "Agricultural Land", color = "#F0B27A") |> + tibble::add_row(name = "Urban_Built_Up", color = "#85929E") |> + tibble::add_row(name = "Agricultural_Land", color = "#F0B27A") |> tibble::add_row(name = "Rangeland", color = "#F1C40F") |> - tibble::add_row(name = "Forest Land", color = "#27AE60") |> + tibble::add_row(name = "Forest_Land", color = "#27AE60") |> tibble::add_row(name = "Water", color = "#2980B9") |> tibble::add_row(name = "Wetland", color = "#D4E6F1") |> - tibble::add_row(name = "Barren Land", color = "#FDEBD0") |> + tibble::add_row(name = "Barren_Land", color = "#FDEBD0") |> tibble::add_row(name = "Tundra", color = "#EBDEF0") |> - tibble::add_row(name = "Snow and Ice", color = "#F7F9F9") + tibble::add_row(name = "Snow_and_Ice", color = "#F7F9F9") # Load the color table into `sits` - sits_colors_set(us_nlcd) + sits_colors_set(colors = us_nlcd, legend = "US_NLCD") # Show the new color table used by sits - sits_colors_show() + sits_colors_show("US_NLCD") + + # Change colors in the sits global color table + # First show the default colors for the UMD legend + sits_colors_show("UMD") + # Then change some colors associated to the UMD legend + mycolors <- tibble::tibble(name = character(), color = character()) + mycolors <- mycolors |> + tibble::add_row(name = "Savannas", color = "#F8C471") |> + tibble::add_row(name = "Grasslands", color = "#ABEBC6") + sits_colors_set(colors = mycolors) + # Notice that the UMD colors change + sits_colors_show("UMD") + # Reset the color table + sits_colors_reset() + # Show the default colors for the UMD legend + sits_colors_show("UMD") } } \author{ diff --git a/man/sits_colors_show.Rd b/man/sits_colors_show.Rd index 7f88eee90..143fcc7b8 100644 --- a/man/sits_colors_show.Rd +++ b/man/sits_colors_show.Rd @@ -4,7 +4,7 @@ \alias{sits_colors_show} \title{Function to show colors in SITS} \usage{ -sits_colors_show(legend = NULL, font_family = "plex_sans") +sits_colors_show(legend = NULL, font_family = "sans") } \arguments{ \item{legend}{One of the accepted legends in sits} diff --git a/man/sits_cube.Rd b/man/sits_cube.Rd index 55099630d..955bebd34 100644 --- a/man/sits_cube.Rd +++ b/man/sits_cube.Rd @@ -307,7 +307,7 @@ if (sits_run_examples()) { ## Sentinel-1 SAR from MPC roi_sar <- c("lon_min" = -50.410, "lon_max" = -50.379, - "lat_min" = -10.1910, "lat_max" = -10.1573) + "lat_min" = -10.1910, "lat_max" = -10.1573) s1_cube_open <- sits_cube( source = "MPC", @@ -316,7 +316,7 @@ if (sits_run_examples()) { roi = roi_sar, start_date = "2020-06-01", end_date = "2020-09-28" - ) + ) # --- Create a cube based on a local MODIS data data_dir <- system.file("extdata/raster/mod13q1", package = "sits") diff --git a/man/sits_label_classification.Rd b/man/sits_label_classification.Rd index 68e7f9df1..991b42a2a 100644 --- a/man/sits_label_classification.Rd +++ b/man/sits_label_classification.Rd @@ -12,10 +12,8 @@ \usage{ sits_label_classification( cube, - clean = TRUE, - window_size = 3L, - memsize = 4, - multicores = 2, + memsize = 4L, + multicores = 2L, output_dir, version = "v1", progress = TRUE @@ -24,8 +22,6 @@ sits_label_classification( \method{sits_label_classification}{probs_cube}( cube, ..., - clean = TRUE, - window_size = 3L, memsize = 4L, multicores = 2L, output_dir, @@ -52,13 +48,6 @@ sits_label_classification( \arguments{ \item{cube}{Classified image data cube.} -\item{clean}{A logical value to apply a modal function to clean up -possible noisy pixels keeping the most frequently -values within the neighborhood. Default is TRUE.} - -\item{window_size}{An odd integer representing the size of the -sliding window of the modal function (min = 1, max = 15).} - \item{memsize}{maximum overall memory (in GB) to label the classification.} diff --git a/man/sits_sampling_design.Rd b/man/sits_sampling_design.Rd new file mode 100644 index 000000000..f04fc4c73 --- /dev/null +++ b/man/sits_sampling_design.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/sits_sample_functions.R +\name{sits_sampling_design} +\alias{sits_sampling_design} +\title{Allocation of sample size to strata} +\usage{ +sits_sampling_design( + cube, + expected_ua = 0.75, + std_err = 0.01, + rare_class_prop = 0.1 +) +} +\arguments{ +\item{cube}{Classified cube} + +\item{expected_ua}{Expected values of user's accuracy} + +\item{std_err}{Standard error we would like to achieve} + +\item{rare_class_prop}{Proportional area limit for rare classes} +} +\value{ +A matrix with options to decide allocation +of sample size to each class. This matrix uses the same format as +Table 5 of Olofsson et al.(2014). +} +\description{ +Takes a class cube with different labels and allocates a number of +sample sizes per strata to obtain suitable values of error-adjusted area, +providing five allocation strategies. +} +\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 + ) + # classify a data cube + probs_cube <- sits_classify( + data = cube, ml_model = rfor_model, output_dir = tempdir() + ) + # label the probability cube + label_cube <- sits_label_classification( + probs_cube, + output_dir = tempdir() + ) + # estimated UA for classes + expected_ua <- c(Cerrado = 0.75, Forest = 0.9, + Pasture = 0.8, Soy_Corn = 0.8) + sampling_design <- sits_sampling_design(label_cube, expected_ua) +} +} +\references{ +[1] Olofsson, P., Foody, G.M., Stehman, S.V., Woodcock, C.E. (2013). +Making better use of accuracy data in land change studies: Estimating +accuracy and area and quantifying uncertainty using stratified estimation. +Remote Sensing of Environment, 129, pp.122-131. + +[2] Olofsson, P., Foody G.M., Herold M., Stehman, S.V., +Woodcock, C.E., Wulder, M.A. (2014) +Good practices for estimating area and assessing accuracy of land change. +Remote Sensing of Environment, 148, pp. 42-57. +} +\author{ +Gilberto Camara, \email{gilberto.camara@inpe.br} +} diff --git a/man/sits_to_xlsx.Rd b/man/sits_to_xlsx.Rd index 457ac8a80..fcdc35238 100644 --- a/man/sits_to_xlsx.Rd +++ b/man/sits_to_xlsx.Rd @@ -2,16 +2,21 @@ % Please edit documentation in R/sits_xlsx.R \name{sits_to_xlsx} \alias{sits_to_xlsx} +\alias{sits_to_xlsx.sits_accuracy} +\alias{sits_to_xlsx.list} \title{Save accuracy assessments as Excel files} \usage{ -sits_to_xlsx(acc_lst, file, data = NULL) +sits_to_xlsx(acc, file) + +\method{sits_to_xlsx}{sits_accuracy}(acc, file) + +\method{sits_to_xlsx}{list}(acc, file) } \arguments{ -\item{acc_lst}{A list of accuracy statistics} +\item{acc}{Accuracy statistics (either an output of sits_accuracy +or a list of those)} \item{file}{The file where the XLSX data is to be saved.} - -\item{data}{(optional) Print information about the samples} } \value{ No return value, called for side effects. diff --git a/man/sits_uncertainty.Rd b/man/sits_uncertainty.Rd index 9dcf775c5..22bf2c208 100644 --- a/man/sits_uncertainty.Rd +++ b/man/sits_uncertainty.Rd @@ -2,32 +2,24 @@ % Please edit documentation in R/sits_uncertainty.R \name{sits_uncertainty} \alias{sits_uncertainty} -\alias{sits_uncertainty.least} -\alias{sits_uncertainty.entropy} -\alias{sits_uncertainty.margin} +\alias{sits_uncertainty.probs_cube} +\alias{sits_uncertainty.probs_vector_cube} \alias{sits_uncertainty.default} \title{Estimate classification uncertainty based on probs cube} \usage{ sits_uncertainty( cube, + ..., type = "entropy", - multicores = 2, - memsize = 4, + multicores = 2L, + memsize = 4L, output_dir, version = "v1" ) -\method{sits_uncertainty}{least}( - cube, - type = "least", - multicores = 2, - memsize = 4, - output_dir, - version = "v1" -) - -\method{sits_uncertainty}{entropy}( +\method{sits_uncertainty}{probs_cube}( cube, + ..., type = "entropy", multicores = 2, memsize = 4, @@ -35,20 +27,23 @@ sits_uncertainty( version = "v1" ) -\method{sits_uncertainty}{margin}( +\method{sits_uncertainty}{probs_vector_cube}( cube, - type = "margin", + ..., + type = "entropy", multicores = 2, memsize = 4, output_dir, version = "v1" ) -\method{sits_uncertainty}{default}(cube, type, multicores, memsize, output_dir, version) +\method{sits_uncertainty}{default}(cube, ..., type, multicores, memsize, output_dir, version) } \arguments{ \item{cube}{Probability data cube.} +\item{...}{Other parameters for specific functions.} + \item{type}{Method to measure uncertainty. See details.} \item{multicores}{Number of cores to run the function.} diff --git a/man/sits_xgboost.Rd b/man/sits_xgboost.Rd index 1af5f836d..78a00dacc 100644 --- a/man/sits_xgboost.Rd +++ b/man/sits_xgboost.Rd @@ -14,6 +14,7 @@ sits_xgboost( subsample = 0.8, nfold = 5, nrounds = 100, + nthread = 6, early_stopping_rounds = 20, verbose = FALSE ) @@ -51,6 +52,8 @@ Default: 0.8.} \item{nrounds}{Number of rounds to iterate the cross-validation (default: 100)} +\item{nthread}{Number of threads (default = 6)} + \item{early_stopping_rounds}{Training with a validation set will stop if the performance doesn't improve for k rounds.}