Merge branch 'dev' of https://github.com/e-sensing/sits into feat/impute-methods

Author: M3nin0

DESCRIPTION

@@ -65,7 +65,7 @@ Imports:
     tibble (>= 3.3.0),
     tidyr (>= 1.3.0),
     tmap (>= 4.1),
-    torch (>= 0.15.0),
+    torch (>= 0.16.3),
     units,
     utils
 Suggests:
@@ -97,6 +97,7 @@ Suggests:
     RColorBrewer,
     RcppArmadillo (>= 14.0.0),
     scales,
+    snic,
     spdep,
     stars,
     stringr,

NAMESPACE

@@ -7,8 +7,10 @@ S3method("sits_bands<-",default)
 S3method("sits_bands<-",raster_cube)
 S3method("sits_bands<-",sits)
 S3method("sits_labels<-",class_cube)
+S3method("sits_labels<-",class_vector_cube)
 S3method("sits_labels<-",default)
 S3method("sits_labels<-",probs_cube)
+S3method("sits_labels<-",probs_vector_cube)
 S3method("sits_labels<-",sits)
 S3method(.accuracy_get_validation,csv)
 S3method(.accuracy_get_validation,data.frame)
@@ -21,6 +23,9 @@ S3method(.check_samples,default)
 S3method(.check_samples,sits)
 S3method(.cube_adjust_crs,default)
 S3method(.cube_adjust_crs,grd_cube)
+S3method(.cube_area_freq,class_cube)
+S3method(.cube_area_freq,class_vector_cube)
+S3method(.cube_area_freq,default)
 S3method(.cube_as_sf,default)
 S3method(.cube_as_sf,raster_cube)
 S3method(.cube_bands,default)
@@ -143,6 +148,10 @@ S3method(.samples_select_bands,sits_base)
 S3method(.samples_select_dates,sits)
 S3method(.samples_select_labels,sits)
 S3method(.slice_dfr,numeric)
+S3method(.snic_grid_seeds,diamond)
+S3method(.snic_grid_seeds,hexagonal)
+S3method(.snic_grid_seeds,random)
+S3method(.snic_grid_seeds,rectangular)
 S3method(.source_collection_access_test,"mpc_cube_sentinel-1-grd")
 S3method(.source_collection_access_test,cdse_cube)
 S3method(.source_collection_access_test,cdse_os_cube)
@@ -391,6 +400,8 @@ S3method(sits_clean,class_cube)
 S3method(sits_clean,default)
 S3method(sits_clean,derived_cube)
 S3method(sits_clean,raster_cube)
+S3method(sits_colors_qgis,class_cube)
+S3method(sits_colors_qgis,class_vector_cube)
 S3method(sits_combine_predictions,average)
 S3method(sits_combine_predictions,default)
 S3method(sits_combine_predictions,uncertainty)
@@ -549,7 +560,6 @@ export(sits_labels_summary)
 export(sits_lightgbm)
 export(sits_lighttae)
 export(sits_list_collections)
-export(sits_lstm_fcn)
 export(sits_merge)
 export(sits_mgrs_to_roi)
 export(sits_mixture_model)
@@ -580,6 +590,7 @@ export(sits_sgolay)
 export(sits_show_prediction)
 export(sits_slic)
 export(sits_smooth)
+export(sits_snic)
 export(sits_som_clean_samples)
 export(sits_som_evaluate_cluster)
 export(sits_som_map)

R/api_bbox.R

@@ -233,7 +233,25 @@ NULL
     proj4string <- crs_sf[["proj4string"]]
     proj4string
 }
-
+#' @title Verify if CRS is equal area
+#' @name .crs_is_equal_area
+#' @noRd
+#' @param wkt_crs  CRS in WKT name
+#' @returns  CRS in PROJ4 name
+.crs_is_equal_area <- function(crs) {
+    # Transform CRS to Sf object
+    proj4_string <- sf::st_crs(crs)$proj4string
+    # Define equal area codes
+    equal_area_codes <- c("aea", "laea", "cea", "moll", "sinu", "robin", "vandg")
+    # Verify if CRS is equal area
+    is_equal_area <- any(sapply(equal_area_codes, function(code)
+        grepl(
+            paste0("\\+proj=", code), proj4_string
+        ))
+    )
+    # Return!
+    return(is_equal_area)
+}
 #' @title Check if CRS is WGS84
 #' @name .is_crs_wgs84
 #' @noRd

R/api_check.R

@@ -2954,3 +2954,21 @@
         )
     )
 }
+#' @title Check if grid system is supported
+#' @name .check_snic_grid
+#' @author Rolf Simoes, \email{rolf.simoes@@gmail.com}
+#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
+#' @param snic_grid   Requested SNIC grid system
+#' @return Called for side effects.
+#' @keywords internal
+#' @noRd
+.check_snic_grid <- function(snic_grid) {
+    .check_chr_contains(
+        x = .conf("snic_grids"),
+        contains = snic_grid,
+        case_sensitive = TRUE,
+        discriminator = "one_of",
+        can_repeat = FALSE,
+        msg = .conf("messages", ".check_snic_grid")
+    )
+}

R/api_colors.R

@@ -141,7 +141,7 @@
         )
 }
 #'
-#' @title Write a color table in QGIS Style format
+#' @title Write a raster color table in QGIS Style format
 #' @name .colors_qml
 #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
 #' @keywords internal
@@ -154,7 +154,6 @@
     .check_chr_contains(colnames(color_table), c("index", "color", "name"))
     # open the file connection
     con <- file(file, "w")
-
     # read the top part of QGIS style
     top_qgis_style <- system.file("extdata/qgis/qgis_style_top.xml",
         package = "sits"
@@ -198,6 +197,105 @@
     # close the file
     on.exit(close(con))
 }
+#'
+#' @title Write a vector color table in GIMP Format to be read by QGIS
+#' @name .colors_vector_qml
+#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
+#' @keywords internal
+#' @noRd
+#' @param color_table color table to write to QGIS
+#' @param file the file name to be written to.
+#' @return Called for side effects.
+.colors_vector_qml <- function(color_table, file) {
+    # open the file connection
+    con <- file(file, "w")
+    # find out how many labels have to be written
+    nlabels <- nrow(color_table)
+    # read the top part of QGIS style
+    top_qgis_style <- system.file("extdata/qgis/qgis_style_vector_top.xml",
+                                  package = "sits"
+    )
+    top_lines <- readLines(top_qgis_style)
+    # write the top part of QGIS style in the output file
+    writeLines(top_lines, con = con)
+    # write the start of the categories
+    writeLines("<categories>", con = con)
+    # write the categories
+    ncategories <- nlabels - 1
+    for (i in 0:ncategories) {
+        color_name <- color_table[i + 1, "name"]
+        qml_label <- paste0("label=","\"", color_name, "\"")
+        qml_value <- paste0("value=", "\"", color_name, "\"")
+        qml_symbol <- paste0("symbol=","\"", as.character(i), "\"")
+        writeLines(paste("<category render=\"true\"",
+                         qml_label,
+                         "type=\"string\"",
+                         qml_value,
+                         qml_symbol,
+                         "/>"),
+                   con)
+    }
+    # write the last line of categories
+    qml_symbol_extra <- paste0("\"", as.character(nlabels), "\"")
+    writeLines(paste("<category render=\"false\"",
+                     "label= \"\"",
+                     "type=\"string\"",
+                     "value= \"\"",
+                     "symbol=", qml_symbol_extra, "/>"),
+               con)
+
+    # write the end of the categories
+    writeLines("</categories>", con = con)
+
+    # write the symbols
+    writeLines("<symbols>", con = con)
+    for (i in 0:ncategories) {
+        qml_name <- paste0("name=","\"", as.character(i), "\"")
+        writeLines(paste("<symbol",
+                         "alpha=\"1\"",
+                         "type=\"fill\"",
+                          qml_name,
+                         ">"),
+                   con)
+        # read data
+        data_def <- system.file("extdata/qgis/qgis_data_defined_properties.xml",
+                                      package = "sits"
+        )
+        data_def_lines <- readLines(data_def)
+        # write the top part of QGIS style in the output file
+        writeLines(data_def_lines, con = con)
+        # write the color values
+        writeLines("<layer enabled=\"1\" class=\"SimpleFill\">",
+                   con)
+        writeLines("<Option type=\"Map\">", con)
+        # convert color to RGB and write to XML
+        hex_color <- color_table[i + 1, "color"]
+        rgb <- col2rgb(hex_color)
+        # format RGBA value to be inserted in QML file
+        color_val <- paste0(paste(as.character(rgb), collapse = ","),",255")
+        qml_color <- paste0("value=", "\"",color_val,"\"")
+        # write QML color
+        writeLines(paste("<Option type=\"QString\"",
+                         qml_color, "name=\"color\"/>"),
+                   con)
+        writeLines("<Option type=\"QString\" value=\"solid\" name=\"style\"/>",
+                   con)
+        writeLines("</Option>", con)
+        writeLines("</layer>", con)
+        writeLines("</symbol>", con)
+    }
+    writeLines("</symbols>", con)
+    # read the bottom part of QGIS style
+    bottom_qgis_style <- system.file("extdata/qgis/qgis_style_vector_bottom.xml",
+                                  package = "sits"
+    )
+    bottom_lines <- readLines(bottom_qgis_style)
+    # write the bottom part of QGIS style in the output file
+    writeLines(bottom_lines, con = con)
+    # close the file
+    on.exit(close(con))
+}
+
 #' @title Transform an RColorBrewer name to cols4all name
 #' @name .colors_cols4all_name
 #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}

R/api_cube.R

@@ -367,19 +367,13 @@ NULL
 #'
 #' @return A \code{vector} with the areas of the cube labels.
 .cube_class_areas <- function(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
-        .tile_area_freq(tile)
-    })
-    # Get a tibble by binding the row (duplicated labels with different counts)
-    freq <- do.call(rbind, freq_lst)
+    # Get cube area / pixel frequency
+    freq <- .cube_area_freq(cube)
     # 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
@@ -388,7 +382,40 @@ NULL
     class_areas[is.na(class_areas)] <- 0.0
     class_areas
 }
-
+#' @title Return areas/frequency of classes of a class_cube
+#' @keywords internal
+#' @noRd
+#' @name .cube_area_freq
+#' @param cube       class cube
+#'
+#' @return A \code{vector} with the area and pixel frequency of the cube labels.
+.cube_area_freq <- function(cube) {
+    UseMethod(".cube_area_freq", cube)
+}
+#' @export
+.cube_area_freq.class_cube <- function(cube) {
+    # Get area for each class for each row of the cube
+    slider::slide_dfr(cube, function(tile) {
+        # Get the frequency count and value for each labelled image
+        .tile_area_freq(tile)
+    }) |>
+        dplyr::filter(!is.na(.data[["class"]]))
+}
+#' @export
+.cube_area_freq.class_vector_cube <- function(cube) {
+    # Get area for each class for each row of the cube
+    slider::slide_dfr(cube, function(tile) {
+        # Get the frequency count and value for each labelled image
+        .tile_area_freq(tile)
+    }) |>
+        dplyr::filter(!is.na(.data[["class"]]))
+}
+#' @export
+.cube_area_freq.default <- function(cube) {
+    cube <- tibble::as_tibble(cube)
+    cube <- .cube_find_class(cube)
+    .cube_area_freq(cube)
+}
 #' @title Return bands of a data cube
 #' @keywords internal
 #' @noRd
@@ -1481,6 +1508,10 @@ NULL
         file_info <- slider::slide_dfr(file_info, function(fi) {
             # Get tile path
             path <- fi[["path"]]
+            # is file NA?
+            if (is.na(path)) {
+                return(path)
+            }
             # is file exists in local path?
             if (file.exists(path)) {
                 return(path)

R/api_message.R

@@ -76,6 +76,15 @@
         )
     }
 }
+#' @title Warning when converting a slow area calculation will be performed
+#' @name .message_warnings_slow_area_calculation
+#' @noRd
+#' @returns Called for side effects
+.message_warnings_slow_area_calculation <- function() {
+    if (.message_warnings()) {
+        warning(.conf("messages", "summary_class_cube_slow_area"), call. = FALSE)
+    }
+}
 #' @title Test if progress bar should be shown
 #' @name .message_progress
 #' @noRd