add new function to remove specific samples of a class inside a neuro…

…n of other class

NAMESPACE

@@ -488,6 +488,7 @@ export(sits_smooth)
 export(sits_som_clean_samples)
 export(sits_som_evaluate_cluster)
 export(sits_som_map)
+export(sits_som_remove_samples)
 export(sits_stats)
 export(sits_stratified_sampling)
 export(sits_svm)

R/api_conf.R

@@ -548,23 +548,23 @@
 #'
 #' @return Called for side effects.
 .conf_list_source <- function(source){
- cat(paste0(s, ":\n"))
- collections <- .source_collections(source = s)
- purrr::map(collections, function(c) {
- cat(paste0("- ", c))
+ cat(paste0(source, ":\n"))
+ collections <- .source_collections(source)
+ purrr::map(collections, function(col) {
+ cat(paste0("- ", col))
  cat(paste0(
- " (", .source_collection_satellite(s, c),
- "/", .source_collection_sensor(s, c), ")\n",
- "- grid system: ", .source_collection_grid_system(s, c), "\n"
+ " (", .source_collection_satellite(source, col),
+ "/", .source_collection_sensor(source, col), ")\n",
+ "- grid system: ", .source_collection_grid_system(source, col), "\n"
  ))
  cat("- bands: ")
- cat(.source_bands(s, c))
+ cat(.source_bands(source, col))
  cat("\n")
- if (.source_collection_open_data(source = s, collection = c)) {
+ if (.source_collection_open_data(source, col)) {
  cat("- opendata collection ")
  if (.source_collection_open_data(
- source = s,
- collection = c,
+ source = source,
+ collection = col,
  token = TRUE
  )) {
  cat("(requires access token)")

R/api_plot_raster.R

@@ -46,8 +46,8 @@
  # extract the values
  vals <- terra::values(rast)
  # obtain the quantiles
- fst_quant <- .as.numeric(.conf("plot", "first_quantile"))
- lst_quant <- .as.numeric(.conf("plot", "last_quantile"))
+ fst_quant <- as.numeric(.conf("plot", "first_quantile"))
+ lst_quant <- as.numeric(.conf("plot", "last_quantile"))
  quantiles <- stats::quantile(
  vals,
  probs = c(0, fst_quant, lst_quant, 1),
@@ -259,14 +259,14 @@
  ),
  proxy = FALSE
  )
- fst_quant <- .as.numeric(.conf("plot", "first_quantile"))
- lst_quant <- .as.numeric(.conf("plot", "last_quantile"))
+ fst_quant <- as.numeric(.conf("plot", "first_quantile"))
+ lst_quant <- as.numeric(.conf("plot", "last_quantile"))
  # open RGB stars
  rgb_st <- stars::st_rgb(rgb_st[, , , 1:3],
  dimension = "band",
  maxColorValue = max_value,
  use_alpha = FALSE,
- probs = c(fst_quant, las_quant),
+ probs = c(fst_quant, lst_quant),
  stretch = TRUE
  )
  # tmap params

R/sits_config.R

@@ -64,8 +64,6 @@ sits_config <- function(config_user_file = NULL) {
 }
 #' @title Show current sits configuration
 #' @name sits_config_show
-#' @param source Data source (character vector).
-#' @param collection Collection (character vector).
 #'
 #' @description
 #' Prints the current sits configuration options.
@@ -94,7 +92,7 @@ sits_config_show <- function() {
  config_view <- sits_env[["config"]][["view"]]
  .conf_list_params(config_view)
 
- cat("User sits_config_user_file() to create a user configuration file")
+ cat("Use sits_config_user_file() to create a user configuration file")
  return(invisible(NULL))
 }
 
@@ -138,12 +136,14 @@ sits_list_collections <- function(source = NULL) {
 #' @title List the cloud collections supported by sits
 #' @name sits_config_user_file
 #' @param file_path file to store the user configuration file
+#' @param overwrite replace current configurarion file?
 #' @description
 #' Creates a user configuration file.
 #'
 #' @return Called for side effects
 #' @examples
-#' sits_config_user_file(tempdir(), "my_config_file.yml")
+#' user_file <- paste0(tempdir(), "/my_config_file.yml")
+#' sits_config_user_file(user_file)
 #' @export
 sits_config_user_file <- function(file_path, overwrite = FALSE){
  # get default user configuration file
@@ -181,7 +181,7 @@ sits_config_user_file <- function(file_path, overwrite = FALSE){
 
  if (update)
  warning(.conf("messages", "sits_config_user_file_updated"))
- else if (newfile)
+ else if (new_file)
  warning(.conf("messages", "sits_config_user_file_new_file"))
  else
  warning(.conf("messages", "sits_config_user_file_no_update"))

R/sits_som.R

@@ -371,3 +371,42 @@ sits_som_evaluate_cluster <- function(som_map) {
  )
  return(purity_by_cluster)
 }
+#' @title Evaluate cluster
+#' @name sits_som_remove_samples
+#' @description
+#' Remove samples from a given class inside a neuron of another class
+#' @param som_map A SOM map produced by the som_map() function
+#' @param som_eval An evaluation produced by the som_eval() function
+#' @param class_cluster Dominant class of a set of neurons
+#' @param class_remove Class to be removed from the neurons of the "class_cluster"
+#' @return A new set of samples with the desired class neurons remove
+#' @examples
+#' if (sits_run_examples()) {
+#' # create a som map
+#' som_map <- sits_som_map(samples_modis_ndvi)
+#' # evaluate the som map and create clusters
+#' som_eval <- sits_som_evaluate_cluster(som_map)
+#' # clean the samples
+#' new_samples <- sits_som_remove_samples(som_map, som_eval, "Pasture", "Cerrado")
+#' }
+#' @export
+sits_som_remove_samples <- function(som_map, som_eval, class_cluster, class_remove){
+
+ # get the samples with id_neuron
+ data <- som_map$data
+ # get the samples by neurons
+ neurons <- som_map$labelled_neurons
+
+ neurons_class_1 <- dplyr::filter(neurons, .data[["label_samples"]] == class_cluster
+ & .data[["prior_prob"]] > 0.50)
+ id_neurons_class_1 <- neurons_class_1[["id_neuron"]]
+ # find samples of class2 in neurons of class1
+ samples_remove <- dplyr::filter(data, .data[["label"]] == class_remove &
+ .data[["id_neuron"]] %in% id_neurons_class_1)
+ # get the id of the samples to be removed
+ id_samples_remove <- samples_remove[["id_sample"]]
+ # obtain the new samples
+ new_samples <- dplyr::filter(data, !(.data[["id_sample"]] %in% id_samples_remove))
+ # return the new samples
+ return(new_samples)
+}