R/sits_colors.R

In e-sensing/sits: Satellite Image Time Series Analysis for Earth Observation Data Cubes

#' @title Function to retrieve sits color table
#' @name sits_colors
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
#' @param legend  One of the accepted legends in sits
#' @description Returns a color table
#' @return              A tibble with color names and values
#'
#'
#' @examples
#' if (sits_run_examples()) {
#'     # return the names of all colors supported by SITS
#'     sits_colors()
#' }
#' @export
#'
sits_colors <- function(legend = NULL) {
    if (purrr::is_null(legend)) {
        print("Returning all available colors")
        return(sits_env$color_table)
    } else {
        if (legend %in% sits_env$legends) {
            colors <- .conf(legend)
            color_table_legend <- .conf_colors() |>
                dplyr::filter(.data[["name"]] %in% colors)
            color_table_legend <- color_table_legend[
                match(colors, color_table_legend$name), ]
            return(color_table_legend)
        } else {
            print("Selected map legend not available")
            leg <- paste0(paste("Please select one of the legends: "),
                          paste(names(sits_env$legends), collapse = ", "))
            print(leg)
            return(NULL)
        }
    }
}
#' @title Function to show colors in SITS
#' @name sits_colors_show
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
#' @description         Shows the default SITS colors
#' @param legend  One of the accepted legends in sits
#' @param font_family A font family loaded in SITS
#'
#' @return  no return, called for side effects
#'
#' @examples
#' if (sits_run_examples()) {
#'     # show the colors supported by SITS
#'     sits_colors_show()
#' }
#' @export
#'
sits_colors_show <- function(legend = NULL,
                             font_family = "sans") {
    # verifies if sysfonts package is installed
    .check_require_packages("sysfonts")
    # legend must be valid
    if (purrr::is_null(legend))
        legend <- "none"
    if (!(legend %in% names(sits_env$legends))) {
        msg <- paste0(paste("Please select one of the legends: "),
                      paste(names(sits_env$legends), collapse = ", "))
        print(msg)
        return(invisible(NULL))
    }
    # retrieve the color names associated to the legend
    colors <- sits_env$legends[[legend]]
    # retrive the HEX codes associated to each color
    color_table_legend <- sits_env$color_table |>
        dplyr::filter(.data[["name"]] %in% colors)
    # order the colors to match the order of the legend
    color_table_legend <- color_table_legend[
        match(colors, color_table_legend$name), ]
    # plot the colors
    g <- .colors_show(color_table_legend, font_family)

    return(g)
}

#' @title Function to set sits color table
#' @name sits_colors_set
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
#' @description Includes new colors in the SITS color sets. If the colors exist,
#'              replace them with the new HEX value. Optionally, the new colors
#'              can be associated to a legend. In this case, the new legend
#'              name should be informed.
#'              The colors parameter should be a data.frame or a tibble
#'              with name and HEX code. Colour names should be one character
#'              string only. Composite names need to be combined with
#'              underscores (e.g., use "Snow_and_Ice" instead of "Snow and Ice").
#'
#'              This function changes the global sits color table and the
#'              global set of sits color legends. To undo these effects,
#'              please use "sits_colors_reset()".
#'
#' @param colors New color table (a tibble or data.frame with name and HEX code)
#' @param legend Legend associated to the color table (optional)
#' @return      A modified sits color table (invisible)
#'
#' @examples
#' if (sits_run_examples()) {
#'     # Define a color table based on the Anderson Land Classification System
#'     us_nlcd <- tibble::tibble(name = character(), color = character())
#'     us_nlcd <- us_nlcd |>
#'         tibble::add_row(name = "Urban_Built_Up", color = "#85929E") |>
#'         tibble::add_row(name = "Agricultural_Land", color = "#F0B27A") |>
#'         tibble::add_row(name = "Rangeland", color = "#F1C40F") |>
#'         tibble::add_row(name = "Forest_Land", color = "#27AE60") |>
#'         tibble::add_row(name = "Water", color = "#2980B9") |>
#'         tibble::add_row(name = "Wetland", color = "#D4E6F1") |>
#'         tibble::add_row(name = "Barren_Land", color = "#FDEBD0") |>
#'         tibble::add_row(name = "Tundra", color = "#EBDEF0") |>
#'         tibble::add_row(name = "Snow_and_Ice", color = "#F7F9F9")
#'
#'     # Load the color table into `sits`
#'     sits_colors_set(colors = us_nlcd, legend = "US_NLCD")
#'
#'     # Show the new color table used by sits
#'     sits_colors_show("US_NLCD")
#'
#'     # Change colors in the sits global color table
#'     # First show the default colors for the UMD legend
#'     sits_colors_show("UMD")
#'     # Then change some colors associated to the UMD legend
#'     mycolors <- tibble::tibble(name = character(), color = character())
#'     mycolors <- mycolors |>
#'         tibble::add_row(name = "Savannas", color = "#F8C471") |>
#'         tibble::add_row(name = "Grasslands", color = "#ABEBC6")
#'     sits_colors_set(colors = mycolors)
#'     # Notice that the UMD colors change
#'     sits_colors_show("UMD")
#'     # Reset the color table
#'     sits_colors_reset()
#'     # Show the default colors for the UMD legend
#'     sits_colors_show("UMD")
#' }
#' @export
#'
sits_colors_set <- function(colors, legend = NULL) {
    # add the new color table
    new_color_tb <- .conf_add_color_table(colors)
    if (!purrr::is_null(legend)) {
        # add the list of color names to a new legend
        .check_chr_parameter(legend, msg = "invalid legend")
        # crete a new legend entry
        new_legend_entry <- list()
        # add the colors from the color table
        new_legend_entry[[1]] <- dplyr::pull(colors, .data[["name"]])
        # give a new to the new legend entry
        names(new_legend_entry) <- legend
        sits_env$legends <- c(sits_env$legends, new_legend_entry)
    }
    return(invisible(new_color_tb))
}
#' @title Function to reset sits color table
#' @name sits_colors_reset
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
#' @description Resets the color table
#' @return      No return, called for side effects
#'
#' @examples
#' if (sits_run_examples()) {
#'     # reset the default colors supported by SITS
#'     sits_colors_reset()
#' }
#' @export
#'
sits_colors_reset <- function() {
    .conf_load_color_table()
    return(invisible(NULL))
}
#' @title Function to save color table as QML style for data cube
#' @name sits_colors_qgis
#' @author Gilberto Camara, \email{gilberto.camara@@inpe.br}
#' @description Saves a color table associated to a classified
#'              data cube as a QGIS style file
#' @param   cube a classified data cube
#' @param   file a QGIS style file to be written to
#' @return      No return, called for side effects
#'
#' @examples
#' if (sits_run_examples()) {
#'     # reset the default colors supported by SITS
#'     sits_colors_reset()
#' }
#' @export
#'
sits_colors_qgis <- function(cube, file) {
    # check if cube is a class cube
    .check_cube_is_class_cube(cube)
    # check if the file name is valid
    .check_file(file,
                file_exists = FALSE,
                msg = "Please select a valid file name")
    # retrieve the labels of the cube
    labels <- sits_labels(cube)
    # select the colors for the labels of the cube
    color_table <- .conf_colors()
    # check all labels are in the color table
    .check_chr_within(labels,
                      color_table$name,
                      msg = "all labels should be included in the color table")
    # filter the color table
    color_table <- color_table |>
        dplyr::filter(.data[["name"]] %in% labels)
    # order the colors to match the order of the labels
    color_table <- color_table[
        match(labels, color_table$name), ]
    # include an index
    color_table$index <- names(labels)
    # create a QGIS XML file
    .colors_qml(color_table, file)
    return(invisible(NULL))
}