plot legends in som map

R/api_check.R

@@ -2459,6 +2459,22 @@
                             discriminator = "any_of")
     return(invisible(NULL))
 }
+#' @title Check legend defined as tibble
+#' @name .check_legend
+#' @param legend      Legend (as tibble)
+#' @return Called for side effects
+#' @keywords internal
+#' @noRd
+.check_legend <- function(legend) {
+    .check_set_caller(".check_legend")
+    .check_chr_contains(
+        x = colnames(legend),
+        contains = c("name", "color"),
+        discriminator = "all_of",
+        msg = .conf("messages", ".check_legend")
+    )
+    return(invisible(NULL))
+}
 #' @title Checks legend_position
 #' @name .check_legend_position
 #' @param legend_position      Character vector with legend position
@@ -2475,6 +2491,23 @@
     )
     return(invisible(NULL))
 }
+#' @title Checks if band is in list of bands
+#' @name .check_band_in_bands
+#' @param band    Name of band
+#' @param bands   List of bands
+#' @return Called for side effects
+#' @keywords internal
+#' @noRd
+.check_band_in_bands <- function(band, bands) {
+    .check_set_caller("check_band_in_bands")
+    .check_chr_contains(
+        x = bands,
+        contains = band,
+        discriminator = "one_of",
+        msg = .conf("messages", ".check_band_in_bands")
+    )
+    return(invisible(NULL))
+}
 #' @title Checks shapefile attribute
 #' @name .check_shp_attribute
 #' @param sf_shape      sf object read from a shapefile

R/api_colors.R

@@ -217,3 +217,19 @@
     }
     return(c4a_pal_name)
 }
+#' @title Transform an legend from tibble to vector
+#' @name .colors_legend_set
+#' @keywords internal
+#' @noRd
+#' @param legend A legend in tibble format
+#' @return A valid legend as vector
+#'
+.colors_legend_set <- function(legend){
+    if ("tbl_df" %in% class(legend)) {
+        .check_legend(legend)
+        legend_vec <- legend[["color"]]
+        names(legend_vec) <- legend[["name"]]
+        return(legend_vec)
+    }
+    return(legend)
+}

R/api_som.R

@@ -145,24 +145,28 @@
 #'              of the last iteration of SOM
 #'              in function sits_cluster_som
 #'
-#' @param kohonen_obj    Object kohonen
+#' @param koh            Object kohonen
 #'                       provided by package Kohonen
+#' @param legend         Legend (optional)
 #' @return               kohonen_obj with a new parameter with the
 #'                       colour of the neuron.
 #'
-.som_paint_neurons <- function(kohonen_obj) {
-    # assign one color per unique label
+.som_paint_neurons <- function(koh, legend = NULL) {
 
+    # convert legend from tibble to vector
+    if (.has(legend))
+        legend <- .colors_legend_set(legend)
+    # assign one color per unique label
     colors <- .colors_get(
-        labels = kohonen_obj[["neuron_label"]],
-        legend = NULL,
+        labels = unique(koh[["som_properties"]][["neuron_label"]]),
+        legend = legend,
         palette = "Set3",
         rev = TRUE
     )
-    labels <- kohonen_obj[["neuron_label"]]
-    kohonen_obj[["paint_map"]] <- unname(colors[labels])
+    labels <- koh[["som_properties"]][["neuron_label"]]
+    koh[["som_properties"]][["paint_map"]] <- unname(colors[labels])
 
-    return(kohonen_obj)
+    return(koh)
 }
 
 #' @title Adjacency matrix

R/sits_plot.R

@@ -1420,6 +1420,8 @@ plot.class_cube <- function(x, y, ...,
     .check_int_parameter(max_cog_size, min = 512)
     # check legend position
     .check_legend_position(legend_position)
+    # check legend - convert to vector if legend is tibble
+    legend <- .colors_legend_set(legend)
     # check for color_palette parameter (sits 1.4.1)
     dots <- list(...)
     # get tmap params from dots
@@ -1747,7 +1749,8 @@ plot.som_evaluate_cluster <- function(x, y, ...,
 #' @param  ...        Further specifications for \link{plot}.
 #' @param  type       Type of plot: "codes" for neuron weight (time series) and
 #'                    "mapping" for the number of samples allocated in a neuron.
-#' @param  band       What band will be plotted.
+#' @param  legend     Legend with colors to be plotted
+#' @param  band       What band will be plotted (character)
 #'
 #' @return            Called for side effects.
 #'
@@ -1764,23 +1767,39 @@ plot.som_evaluate_cluster <- function(x, y, ...,
 #' }
 #' @export
 #'
-plot.som_map <- function(x, y, ..., type = "codes", band = 1) {
+plot.som_map <- function(x, y, ..., type = "codes", legend = NULL, band = NULL) {
     stopifnot(missing(y))
     koh <- x
     if (!inherits(koh, "som_map")) {
         message(.conf("messages", ".plot_som_map"))
         return(invisible(NULL))
     }
+    # set band
+    bands <- names(koh[["som_properties"]][["codes"]])
+    # check if band name is available
+    if (.has(band)) {
+        .check_band_in_bands(band, bands)
+        # create a numeric vector for plotting
+        bands_koh <- seq_len(length(bands))
+        names(bands_koh) <- bands
+        whatmap <- bands_koh[[band]]
+    } else {
+        whatmap <- 1
+    }
+
+
+    # paint neurons
+    koh <- .som_paint_neurons(koh, legend)
     if (type == "mapping") {
         graphics::plot(koh[["som_properties"]],
             bgcol = koh[["som_properties"]][["paint_map"]],
-            "mapping", whatmap = band,
+            "mapping", whatmap = whatmap,
             codeRendering = "lines"
         )
     } else if (type == "codes") {
         graphics::plot(koh[["som_properties"]],
             bgcol = koh[["som_properties"]][["paint_map"]],
-            "codes", whatmap = band,
+            "codes", whatmap = whatmap,
             codeRendering = "lines"
         )
     }

R/sits_som.R

@@ -192,10 +192,6 @@ sits_som_map <- function(data,
     labels_max <- unlist(lab_max)
     # prepare a color assignment to the SOM map
     kohonen_obj[["neuron_label"]] <- labels_max
-    # only paint neurons if number of labels is greater than one
-    if (length(unique(labels_max)) > 1) {
-        kohonen_obj <- .som_paint_neurons(kohonen_obj)
-    }
     # return the som_map object
     som_map <-
         list(

inst/extdata/config_messages.yml

@@ -2,6 +2,7 @@
 #
 .check_apply: "invalid function provided to be applied"
 .check_available_bands: 'requested band(s) not available in the cube'
+.check_band_in_bands: "requested band(s) not available"
 .check_bbox: "input is not a valid bbox"
 .check_bw_rgb_bands: "either 'band' parameter or 'red', 'green', and 'blue' parameters should be informed"
 .check_crs: "invalid crs information in image files"
@@ -54,6 +55,7 @@
 .check_labels: "missing labels in some or all of reference data"
 .check_labels_class_cube: "labels do not match number of classes in cube"
 .check_labels_probs_cube: "labels are not available in probs cube"
+.check_legend: "when defined as a tibble, legend needs name and color columns"
 .check_legend_position: "legend position is either inside or outside"
 .check_length: "invalid length for parameter"
 .check_lgl: "invalid logical value"

sits.Rproj

@@ -1,4 +1,5 @@
 Version: 1.0
+ProjectId: 30147940-5ac6-4daa-88b6-6d66533383e5
 
 RestoreWorkspace: Default
 SaveWorkspace: Ask