Merge pull request #1419 from M3nin0/fix/area-calculation

enhance area strategy by checking equal area crs

Author: gilbertocamara

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_tile.R

@@ -1394,15 +1394,17 @@ NULL
 #' @export
 .tile_area_freq.class_cube <- function(tile) {
     # get tile crs
-    tile_crs <- .tile_crs(tile)
+    tile_crs <- sf::st_crs(.tile_crs(tile))
     # get tile crs unit (metre or degree)
-    tile_crs_unit <- sf::st_crs(tile_crs)$units_gdal
+    tile_crs_unit <- tile_crs$units_gdal
+    # validate if crs is equal area
+    tile_crs_equal_area <- .crs_is_equal_area(tile_crs)
     # extract the file path
     tile_file <- .tile_paths(tile)
     # read the files with terra
     rast <- .raster_open_rast(tile_file)
     # get area by pixels
-    if (tile_crs_unit == "metre") {
+    if (!tile_crs_equal_area && tile_crs_unit == "metre") {
         # get a frequency of values
         class_areas <- .raster_freq(rast) |>
             dplyr::select(-.data[["layer"]])

R/sits_summary.R

@@ -447,12 +447,12 @@ summary.variance_cube <- function(object, ...,
 #' @export
 summary.class_cube <- function(object, ...) {
     .check_set_caller("summary_class_cube")
-    # check if cube has only metre crs
+    # check if cube has only metre crs and is not equal area
     cube_has_only_metre_crs <- slider::slide_lgl(object, function(tile) {
         # get tile crs
-        tile_crs <- .tile_crs(tile)
+        tile_crs <- sf::st_crs(.tile_crs(tile))
         # check unit
-        sf::st_crs(tile_crs)$units_gdal == "metre"
+        tile_crs$units_gdal == "metre" && !.crs_is_equal_area(tile_crs)
     })
     # all must be true
     cube_has_only_metre_crs <- all(cube_has_only_metre_crs)