Merge pull request #1058 from e-sensing/dev

Pre-realease 1.4.2-3

Author: OldLipe

.gitignore

@@ -21,6 +21,7 @@ inst/doc
 doc
 Meta
 *.bkp
+*.pdf
 .sits/
 *.gcda
 *.gcno

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 = '[email protected]'),
              person('Gilberto', 'Camara', role = c('aut', 'cre'), email = '[email protected]'),
@@ -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'

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)

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
 

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,

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,

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)
 }

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,38 +204,39 @@
         )
         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),
         contains = .conf("sits_color_table_cols"),
         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"]],

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