include different legends in color tables

DESCRIPTION

@@ -54,6 +54,8 @@ Imports:
     Rcpp,
     rstac (>= 0.9.2-3),
     sf (>= 1.0-12),
+    showtext,
+    sysfonts,
     slider (>= 0.2.0),
     stats,
     terra (>= 1.5-17),
@@ -89,6 +91,7 @@ Suggests:
     RcppArmadillo (>= 0.11),
     scales,
     stars (>= 0.6),
+    stringr,
     supercells,
     testthat (>= 3.1.3),
     tmap (>= 3.3),

R/api_colors.R

@@ -82,8 +82,10 @@
 #' @param color_tb A SITS color table
 #' @return a gglot2 object
 .colors_show <- function(color_tb) {
+    color_tb$name <- purrr::map_chr(color_tb$name, function(name)
+        { paste(name = unlist(strsplit(name, split = "_")), collapse = " ")})
     n_colors <- nrow(color_tb)
-    n_rows_show <- n_colors %/% 3
+    n_rows_show <- n_colors %/% 4
     color_tb <- tibble::add_column(color_tb,
         y = seq(0, n_colors - 1) %% n_rows_show,
         x = seq(0, n_colors - 1) %/% n_rows_show
@@ -115,12 +117,13 @@
             mapping = ggplot2::aes(
                 x = .data[["x"]] + 0.5,
                 y = .data[["y"]] + 0.8,
-                label = .data[["name"]]
+                label = stringr::str_wrap(.data[["name"]], width = 10)
             ),
+            family = "opensans",
             colour = "grey15",
             hjust = 0.5,
             vjust = 1,
-            size = 9 / ggplot2::.pt
+            size = 10 / ggplot2::.pt
         )
 
     g + ggplot2::theme(

R/api_conf.R

@@ -189,9 +189,14 @@
         input = color_yml_file,
         merge.precedence = "override"
     )
-    config_colors <- config_colors$colors
-    base_names <- names(config_colors)
-    color_table <- purrr::map2_dfr(config_colors, base_names, function(cl, bn) {
+    class_schemes <- config_colors$class_schemes
+    sits_env[["config"]] <- utils::modifyList(sits_env[["config"]],
+                                              class_schemes,
+                                              keep.null = FALSE
+    )
+    colors <- config_colors$colors
+    base_names <- names(colors)
+    color_table <- purrr::map2_dfr(colors, base_names, function(cl, bn) {
         cc_tb <- tibble::tibble(
             name = names(cl),
             color = unlist(cl),
@@ -262,6 +267,20 @@
 .conf_colors <- function() {
     return(sits_env$color_table)
 }
+#' @title Configure fonts to be used
+#' @name .conf_set_fonts
+#' @keywords internal
+#' @noRd
+#' @return NULL, called for side effects
+#'
+.conf_set_fonts <- function() {
+    library(showtext)
+    library(sysfonts)
+    sysfonts::font_add_google("Open Sans", family = "opensans")
+    sysfonts::font_add_google("IBM Plex Sans", family = "ibm")
+    sysfonts::font_add_google("Noto Sans", family = "noto")
+    return(NULL)
+}
 #' @title Return the user configuration set in enviromental variable
 #' @name .conf_user_env_var
 #' @keywords internal

R/sits_colors.R

@@ -19,6 +19,7 @@ sits_colors <- function() {
 #' @name sits_colors_show
 #' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
 #' @description         Shows the default SITS colors
+#' @param legend  One of the accepted legend in sits
 #'
 #' @return  no return, called for side effects
 #'
@@ -29,9 +30,34 @@ sits_colors <- function() {
 #' }
 #' @export
 #'
-sits_colors_show <- function() {
-    g <- .colors_show(sits_colors())
-    return(g)
+sits_colors_show <- function(legend = NULL) {
+    # verifies if stringr package is installed
+    .check_require_packages("stringr")
+    legends <- .conf("legends")
+    if (purrr::is_null(legend)) {
+        print("Showing all available colors")
+        leg <- paste0(paste("Optional - select one of the legends: "),
+               paste(legends, collapse = ", "))
+        print(leg)
+        g <- .colors_show(sits_colors())
+        return(g)
+    } else {
+        if (legend %in% legends) {
+            colors <- .conf(legend)
+            color_table_legend <- sits_colors() |>
+                dplyr::filter(.data[["name"]] %in% colors)
+            color_table_legend <- color_table_legend[
+                match(colors, color_table_legend$name), ]
+            g <- .colors_show(color_table_legend)
+            return(g)
+        } else {
+            print("Selected map legend not available")
+            leg <- paste0(paste("Please select one of the legends: "),
+                          paste(legends, collapse = ", "))
+            print(leg)
+            return(NULL)
+        }
+    }
 }
 
 #' @title Function to set sits color table
@@ -85,137 +111,3 @@ sits_colors_reset <- function() {
     .conf_load_color_table()
     return(invisible(NULL))
 }
-#' @title Get colors associated to the labels
-#' @name .colors_get
-#' @param  labels  labels associated to the training classes
-#' @param  palette palette from `grDevices::hcl.pals()`
-#'                  replaces default colors
-#'                  when labels are not included in the config palette
-#' @param  rev      revert the order of colors?
-#' @keywords internal
-#' @noRd
-#' @return colors required to display the labels
-.colors_get <- function(labels,
-                        legend,
-                        palette,
-                        rev) {
-    # Get the SITS Color table
-    color_tb <- .conf_colors()
-    # Try to find colors in the SITS color palette
-    names_tb <- dplyr::filter(color_tb, .data[["name"]] %in% labels)$name
-    # find the labels that exist in the color table
-    labels_exist <- labels[labels %in% names_tb]
-    # get the colors for the names that exist
-    colors <- purrr::map_chr(labels_exist, function(l) {
-        col <- color_tb |>
-            dplyr::filter(.data[["name"]] == l) |>
-            dplyr::pull(.data[["color"]])
-        return(col)
-    })
-    # get the names of the colors that exist in the SITS color table
-    names(colors) <- labels_exist
-
-    # if there is a legend?
-    if (!purrr::is_null(legend)) {
-        # what are the names in the legend that are in the labels?
-        labels_leg <- labels[labels %in% names(legend)]
-        # what are the color labels that are included in the legend?
-        colors_leg <- legend[labels_leg]
-        # join color names in the legend to those in default colors
-        colors <- c(
-            colors_leg,
-            colors[!names(colors) %in% names(colors_leg)]
-        )
-    }
-    # are there any colors missing?
-    if (!all(labels %in% names(colors))) {
-        missing <- labels[!labels %in% names(colors)]
-        if (.check_warnings()) {
-            warning(
-                "missing colors for labels ",
-                paste(missing, collapse = ", ")
-            )
-            warning("using palette ", palette, " for missing colors")
-            # grDevices does not work with one color missing
-        }
-        colors_pal <- grDevices::hcl.colors(
-            n = max(2, length(missing)),
-            palette = palette,
-            alpha = 1,
-            rev = rev
-        )
-        # if there is only one color, get it
-        colors_pal <- colors_pal[seq_len(length(missing))]
-        names(colors_pal) <- missing
-        # put all colors together
-        colors <- c(colors, colors_pal)
-    }
-    # rename colors to fit the label order
-    # and deal with duplicate labels
-    colors <- colors[labels]
-    # post-condition
-    .check_chr(colors,
-        len_min = length(labels),
-        len_max = length(labels),
-        is_named = TRUE,
-        has_unique_names = FALSE,
-        msg = "invalid color values"
-    )
-
-    return(colors)
-}
-#' @title Show color table
-#' @name .colors_show
-#' @keywords internal
-#' @noRd
-#' @param color_tb A SITS color table
-#' @return a gglot2 object
-.colors_show <- function(color_tb) {
-    n_colors <- nrow(color_tb)
-    n_rows_show <- n_colors %/% 3
-
-    color_tb <- tibble::add_column(color_tb,
-        y = seq(0, n_colors - 1) %% n_rows_show,
-        x = seq(0, n_colors - 1) %/% n_rows_show
-    )
-    y_size <- 1.2
-    g <- ggplot2::ggplot() +
-        ggplot2::scale_x_continuous(
-            name = "",
-            breaks = NULL,
-            expand = c(0, 0)
-        ) +
-        ggplot2::scale_y_continuous(
-            name = "",
-            breaks = NULL,
-            expand = c(0, 0)
-        ) +
-        ggplot2::geom_rect(
-            data = color_tb,
-            mapping = ggplot2::aes(
-                xmin = .data[["x"]] + 0.05,
-                xmax = .data[["x"]] + 0.95,
-                ymin = .data[["y"]] + 0.05,
-                ymax = .data[["y"]] + y_size
-            ),
-            fill = color_tb$color
-        ) +
-        ggplot2::geom_text(
-            data = color_tb,
-            mapping = ggplot2::aes(
-                x = .data[["x"]] + 0.5,
-                y = .data[["y"]] + 0.8,
-                label = .data[["name"]]
-            ),
-            colour = "grey15",
-            hjust = 0.5,
-            vjust = 1,
-            size = 9 / ggplot2::.pt
-        )
-
-    g + ggplot2::theme(
-        panel.background = ggplot2::element_rect(fill = "#FFFFFF")
-    )
-
-    return(g)
-}

R/sits_config.R

@@ -55,6 +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()
     # return configuration
     return(invisible(sits_env$config))
 }