R/utils_colors.R

In csoneson/iSEE: Interactive SummarizedExperiment Explorer

#' Define Javascript box classes
#'
#' Define Javascript box classes for different coloring based on the \linkS4class{Panel} subclasses.
#' This should be inserted into the \code{head} tag of the UI in \code{\link{iSEE}}.
#'
#' @param instances A list of all \linkS4class{Panel} classes that might be used in the app.
#'
#' @return A string containing the definition for Panel-specific JS classes.
#'
#' @author Aaron Lun
#'
#' @details
#' Note that JS classes seem to only consider lower-case class names,
#' so it would be unwise to use Panels in \code{instances} with class names that only differ by case.
#'
#' @rdname INTERNAL_define_box_statuses
.define_box_statuses <- function(instances) {
    all_modes <- vapply(instances, .encodedName, "")
    first <- !duplicated(all_modes)
    all_modes <- tolower(all_modes[first])
    all_colors <- vapply(instances[first], .getPanelColor, "")

    paste(
        sprintf(".box.box-%s {
        border-top-color: %s;
}
.box.box-solid.box-%s {
        border: 1px solid %s;
}
.box.box-solid.box-%s > .box-header {
        color: #ffffff;
        background: %s;
        background-color: %s;
}
.box.box-solid.box-%s > .box-header a,
.box.box-solid.box-%s > .box-header .btn {
      color: #ffffff;
}
",
            all_modes, all_colors,
            all_modes, all_colors,
            all_modes, all_colors, all_colors,
            all_modes, all_modes
        ),
        collapse="\n"
    )
}

#' Get panel colors
#'
#' Functions to get/set panel colors at the user and developer level.
#' This determines the color of the panel header as well as (for \linkS4class{DotPlot}s) the color and fill of the brush.
#'
#' @param x An instance of a \linkS4class{Panel} class.
#'
#' @return
#' A string containing the color assigned to the class of \code{x}.
#'
#' @details
#' For developers: \code{.panelColor} is a method that should be subclassed for each \linkS4class{Panel} subclass.
#' This determines the color theme for all instances of that class for use in, e.g., headers and box shadings.
#' Developers should choose a color that is dark enough to serve as a background for white text. 
#' We recommend defining colors as hex color codes for full compatibility with both HTML elements and R plots.
#'
#' For users: by default, \code{.getPanelColor} will return the default color of each panel as specified by the developer in \code{.panelColor}.
#' However, users can override this by setting the \code{panel.color} global option to a named character vector of colors (see Examples).
#' This can be used to customize the color scheme for any given call to \code{\link{iSEE}}.
#' The names of the vector should be set to the name of class to be overridden; if a class is not named here, its default color is used.
#'
#' @author Aaron Lun
#'
#' @examples
#' rdp <- ReducedDimensionPlot()
#'
#' # Default color, as specified by the developer:
#' .panelColor(rdp)
#'
#' # Still the default color:
#' .getPanelColor(rdp)
#'
#' # Overriding the default colors:
#' sce <- SingleCellExperiment(list(logcounts=matrix(rnorm(1000), ncol=100)))
#' reducedDim(sce, "PCA") <- matrix(runif(200), ncol=2)
#' 
#' sce <- registerAppOptions(sce, panel.color=c(ReducedDimensionPlot="#1e90ff"))
#' if (interactive()) {
#'     iSEE(sce, initial=list(rdp))
#' }
#'
#' @rdname getPanelColor
#' @export
.getPanelColor <- function(x) {
    opts <- getAppOption("panel.color")
    if (.encodedName(x) %in% names(opts)) {
        as.vector(opts[.encodedName(x)])
    } else {
        .panelColor(x)
    }
}

#' Lighten colors for fill
#'
#' Create a lighter version of the color for each Panel,
#' primarily for use in the fill of a brush.
#'
#' @param col String containing the color of a panel.
#' @param as.vector Logical scalar indicating whether the RGB values should be returned directly.
#'
#' @return String containing the lightened color.
#'
#' @author Aaron Lun
#'
#' @rdname INTERNAL_lighten_color_for_fill
#' @importFrom grDevices col2rgb rgb
.lighten_color_for_fill <- function(col, as.vector=FALSE) {
    new_colors <- 255 - ((255 - col2rgb(col))/5)
    if (!as.vector) {
        new_colors <- rgb(new_colors[1,], new_colors[2,], new_colors[3,], maxColorValue=255)
    }
    new_colors
}

.brushFillOpacity <- 0.25

#' Define the selection colormap
#'
#' Define the colormap when coloring points in a \linkS4class{DotPlot} based on their assigned multiple row/column selection.
#'
#' @param x An \linkS4class{ExperimentColorMap} object.
#' @param levels Character vector containing the available levels of a \code{ColorBy} column derived from a series of multiple selections,
#' usually generated by \code{\link{multiSelectionToFactor}} on the selection information in \code{row_selected} or \code{col_selected}.
#'
#' @return A named character vector of colors for each level in \code{levels}.
#'
#' @details
#' The \code{"unselected"} level is always assigned the grey color;
#' colors for all other levels are generated by \code{\link{colDataColorMap}(x)} or \code{\link{rowDataColorMap}(x)}.
#' The \code{"active"} level is always assigned the first color from these functions, regardless of whether it is present in \code{levels}.
#' This aims to provide some consistency in the coloring when the selections change.
#' 
#' @author Aaron Lun
#' 
#' @examples
#' ecm <- ExperimentColorMap()
#' columnSelectionColorMap(ecm, c("active", "unselected"))
#' columnSelectionColorMap(ecm, c("active", "saved1", "unselected"))
#' columnSelectionColorMap(ecm, c("saved1", "unselected"))
#' columnSelectionColorMap(ecm, c("saved1"))
#'
#' @export
#' @rdname selectionColorMap
columnSelectionColorMap <- function(x, levels) {
    .selectionColorMap(x, levels, FUN=colDataColorMap)
}

#' @export
#' @rdname selectionColorMap
rowSelectionColorMap <- function(x, levels) {
    .selectionColorMap(x, levels, FUN=rowDataColorMap)
}

.selectionColorMap <- function(x, levels, FUN) {
    levels <- union("active", levels)
    levels <- setdiff(levels, "unselected")
    available <- FUN(x, discrete=TRUE)(length(levels))
    names(available) <- levels
    c(available, unselected="grey")
}