Nothing
R/colors.R
In oce: Analysis of Oceanographic Data
Defines functions
palette2breakscolor
colormap_colormap
colormap
colormapGMT
colormapGmtNumeric
colormap_colorize
Documented in
colormap
colormapGMT
# vim: tw=80 shiftwidth=4 softtabstop=4 wrap linebreak expandtab:
#' Data that define some color palettes
#'
#' The `ocecolors` dataset is a list containing color-schemes, used
#' by [oceColorsClosure()] to create functions such as
#' [oceColorsViridis()].
#'
#' @name ocecolors
#'
#' @docType data
#' @author Authored by matplotlib contributers, packaged (with license permission) in oce by Dan Kelley
#'
#' @source The data come from the matplotlib site
#' `https://github.com/matplotlib/matplotlib`.
#'
#' @template colourBlindnessTemplate
#'
#' @family datasets provided with oce
#' @family things related to colors
#'
#' @template colourBlindnessTemplate
NULL
colormapNames <- c("gmt_relief", "gmt_ocean", "gmt_globe", "gmt_gebco")
# keeping this (which was called 'colorize' until 2014-05-07) for a while, but not in NAMESPACE.
colormap_colorize <- function(z=NULL, zlim, zclip=FALSE, breaks,
col=oceColorsViridis, colormap=NULL, segments=1, missingColor="gray",
debug=getOption("oceDebug"))
{
oceDebug(debug, "colormap_colorize(z=",
if (is.null(z)) "(missing)" else paste("c(", z[1], ",...)", sep=""), ",",
"zlim=", if (missing(zlim)) "(missing)" else
paste("c(", zlim[1], ",", zlim[2], "),", sep=""),
"zclip=", zclip, ",",
"breaks=", if (missing(breaks)) "(missing)" else
paste("c(", breaks[1], ",...),", sep=""),
"col=", if (is.function(col)) "(function)" else paste("c(", col[1], ",...)", sep=""), ",",
"colormap=", if (is.null(colormap)) "(missing)" else colormap, ",",
"segments=", segments, ",",
"missingColor=", missingColor,
") { # an internal function\n", sep="", unindent=1)
if (is.null(colormap)) {
if (is.function(col)) {
oceDebug(debug, "col is a function\n")
if (missing(breaks)) {
if (!missing(zlim)) {
breaks <- seq(zlim[1], zlim[2], length.out=200)
} else if (!is.null(z)) {
breaks <- seq(min(z, na.rm=TRUE), max(z, na.rm=TRUE), length.out=200)
} else {
stop("must give z, zlim or breaks")
}
}
if (length(breaks) == 1) {
# special case: 'breaks' means *number* of breaks
if (!missing(zlim) && !is.null(zlim)) {
breaks <- seq(zlim[1], zlim[2], length.out=breaks)
#message("pretty(zlim)")
} else if (!is.null(z)) {
breaks <- pretty(z, n=breaks) # note use of pretty(), which extends from data
#message("pretty(z)")
} else {
stop("must give z or zlim if length(breaks)=1")
}
}
col <- col(length(breaks) - 1)
} else {
# FIXME: should check that it is indeed a color, but how?
col <- col
}
if (is.null(z)) {
oceDebug(debug, "z is NULL\n")
if (missing(zlim) || is.null(zlim))
zlim <- range(breaks)
zcol <- "black"
} else {
oceDebug(debug, "z is not NULL\n")
if (missing(zlim) || is.null(zlim)) {
zlim <- rangeExtended(z) # note the extended range
oceDebug(debug, "zlim not given; calculated as:", paste(zlim, collapse=" "), "\n")
}
i <- findInterval(z, breaks)
tooLow <- i == 0
tooHigh <- i == length(breaks)
i[tooLow] <- 1 # cannot index to 0; col is replaced later
zcol <- col[i]
if (zclip) {
oceDebug(debug, "zclip TRUE: out-of-range get missingColor:", missingColor, "\n")
zcol[tooLow] <- missingColor
zcol[tooHigh] <- missingColor
} else {
oceDebug(debug, "zclip FALSE: out-of-range get end colors\n")
zcol[tooLow] <- col[1]
zcol[tooHigh] <- tail(col, 1)
}
}
} else {
# have a colormap
if (!missing(col))
stop("cannot supply 'col' and 'colormap' at the same time")
if (!missing(breaks))
stop("cannot supply 'breaks' and 'colormap' at the same time")
if (is.character(colormap)) {
colormap <- colormap_colormap(name=colormap, debug=debug-1)
if (missing(zlim))
zlim <- colormap$zlim
missingColor <- colormap$missingColor
}
if (inherits(colormap, "colormap"))
missingColor <- colormap$missingColor
breaks <- NULL
col <- NULL
# Could preallocate but colormaps are small so do not bother
n <- length(colormap$x0)
for (i in seq.int(1, n-1)) {
# FIXME: should below be segments or 1+segments?
delta <- (colormap$x0[i+1] - colormap$x0[i]) / segments
breaks <- c(breaks, seq(from=colormap$x0[i], by=delta, length.out=segments))
col <- c(col, colorRampPalette(c(colormap$col0[i], colormap$col1[i]))(segments))
}
nbreaks <- length(breaks)
# extend a bit to the right
delta <- mean(diff(breaks[1:2])) / 1000
breaks <- c(breaks, breaks[nbreaks] + delta)
# FIXME: next might miss top color
if (is.null(zlim)) {
zlim <- if (is.null(z)) range(breaks)
else rangeExtended(z) # note the extended range
}
if (is.null(z)) {
zcol <- "black"
} else {
zlim <- rangeExtended(z)
i <- findInterval(z, breaks)
tooLow <- i == 0
tooHigh <- i == length(breaks)
i[tooLow] <- 1 # cannot index to 0; col is replaced later
zcol <- col[i]
if (zclip) {
oceDebug(debug, "zclip TRUE: out-of-range get missingColor:", missingColor, "\n")
zcol[tooLow] <- missingColor
zcol[tooHigh] <- missingColor
} else {
oceDebug(debug, "zclip FALSE: out-of-range get end colors\n")
zcol[tooLow] <- col[1]
zcol[tooHigh] <- tail(col, 1)
}
}
}
res <- list(zlim=zlim, breaks=breaks, col=col, zcol=zcol, missingColor=missingColor)
class(res) <- c("list", "colormap")
oceDebug(debug, "} # colormap_colorize(), an internal function\n", sep="", unindent=1)
res
}
# NB: I've not documented this, because it is not in the NAMESPACE.
colormapGmtNumeric <- function(x0, x1, col0, col1, bpl=1)
{
n <- length(x0)
if (length(x1) != n)
stop("mismatched lengths of x0 and x1 (", n, " and ", length(x1), ")")
if (length(col0) != n)
stop("mismatched lengths of x0 and col0 (", n, " and ", length(col0), ")")
if (length(col1) != n)
stop("mismatched lengths of x0 and col1 (", n, " and ", length(col1), ")")
breaks <- NULL
col <- NULL
# Could preallocate but colormaps are small so do not bother
for (i in seq.int(1, n-1)) {
breaks <- c(breaks, seq(x0[i], x1[i], length.out=1+bpl))
col <- c(col, colorRampPalette(c(col0[i], col1[i]))(1+bpl))
}
nbreaks <- length(breaks)
# extend a bit to the right
delta <- mean(diff(breaks[1:2])) / 1000
breaks <- c(breaks, breaks[nbreaks] + delta)
res <- list(breaks=breaks, col=col)
res
}
#' Create a GMT-type (CPT) colormap
#'
#' `colormapGMT` creates colormaps in the Generic Mapping Tools (GMT)
#' scheme (see References 1 to 4). A few such schemes are built-in, and may be referred to
#' by name (`"gmt_gebco"`, `"gmt_globe"`, `"gmt_ocean"`, or `"gmt_relief"`)
#' while others are handled by reading local files that are in GMT
#' format, or URLs providing such files (see Reference 3).
#'
#' The GMT files understood by [colormapGMT] are what GMT calls
#' "Regular CPT files" (see reference 4). This is a text format that
#' can be read and (with care) edited in a text editor. There
#' are three categories of lines within this file. (1) Any
#' line starting with the `"#"` character is a comment, and is ignored
#' by [colormapGMT]. (2) Lines with 8 numbers specify colour bands.
#' The first number is a z value, and the three numbers after that
#' are red, green and blue values in the range from 0 to 255. This
#' set of 4 numbers is followed on the same line with similar values.
#' Think of this sequence as describing a band of colours between
#' two z values. (3) Lines starting with a character, followed
#' by three numbers, specify particular codings. The character `"B"`
#' specifies background colour, while `"F"` specifies foreground
#' colour, and `"N"` specifies the colour to be used for missing
#' data (the letter stands for not-a-number). Only `"N"` is used
#' by [colormapGMT], and it takes on the role that the `missingColor`
#' argument would otherwise have. (This is why `missingColor` is not
#' permitted if `name` is given.)
#'
#' @param name character value specifying the GMT scheme, or a source for such
#' a scheme. Four pre-defined schemes are available, accessed by setting `name` to
#' `"gmt_gebco"`, `"gmt_globe"`, `"gmt_ocean"`, or `"gmt_relief"`. If `name` is
#' not one of these values, then it is taken to be the name of a local file
#' in GMT format or, if no such file is found, a URL holding such a file.
#'
#' @param debug integer that, if positive, indicates to print some debugging output
#'
#' @return `colormap` returns a list, in the same format as the return value for [colormap()].
#'
#' @author Dan Kelley
#'
#' @references
#' 1. General overview of GMT system
#' `https://www.generic-mapping-tools.org`.
#' 2. Information on GMT color schemes
#' `https://docs.generic-mapping-tools.org/dev/cookbook/cpts.html`
#' 3. Source of GMT specification files
#' `https://beamreach.org/maps/gmt/share/cpt/`
#' 4. CPT (color palette table) format
#' `https://www.soest.hawaii.edu/gmt/gmt/html/GMT_Docs.html#x1-820004.15`
#'
#' @family things related to colors
colormapGMT <- function(name, debug=getOption("oceDebug"))
{
oceDebug(debug, "colormapGMT(name=\"", name, "...)\n", sep="", unindent=1)
if (name %in% colormapNames) {
oceDebug(debug, "case 1: built-in GMT name\n")
if (name == "gmt_relief") {
oceDebug(debug, "case 1.1: built-in gmt_relief\n")
# $Id: GMT_relief.cpt,v 1.1 2001/09/23 23:11:20 pwessel Exp $
#
# Colortable for whole earth relief used in Wessel topomaps
# Designed by P. Wessel and F. Martinez, SOEST
# COLOR_MODEL = RGB
text <- "-8000 0 0 0 -7000 0 5 25
-7000 0 5 25 -6000 0 10 50
-6000 0 10 50 -5000 0 80 125
-5000 0 80 125 -4000 0 150 200
-4000 0 150 200 -3000 86 197 184
-3000 86 197 184 -2000 172 245 168
-2000 172 245 168 -1000 211 250 211
-1000 211 250 211 0 250 255 255
0 70 120 50 500 120 100 50
500 120 100 50 1000 146 126 60
1000 146 126 60 2000 198 178 80
2000 198 178 80 3000 250 230 100
3000 250 230 100 4000 250 234 126
4000 250 234 126 5000 252 238 152
5000 252 238 152 6000 252 243 177
6000 252 243 177 7000 253 249 216
7000 253 249 216 8000 255 255 255
F 255 255 255
B 0 0 0
N 255 255 255"
} else if (name == "gmt_ocean") {
oceDebug(debug, "case 1.2: built-in gmt_ocean\n")
# $Id: GMT_ocean.cpt,v 1.1 2001/09/23 23:11:20 pwessel Exp $
#
# Colortable for oceanic areas as used in Wessel maps
# Designed by P. Wessel and F. Martinez, SOEST.
# COLOR_MODEL = RGB
text <- "-8000 0 0 0 -7000 0 5 25
-7000 0 5 25 -6000 0 10 50
-6000 0 10 50 -5000 0 80 125
-5000 0 80 125 -4000 0 150 200
-4000 0 150 200 -3000 86 197 184
-3000 86 197 184 -2000 172 245 168
-2000 172 245 168 -1000 211 250 211
-1000 211 250 211 0 250 255 255
F 255 255 255
B 0 0 0"
} else if (name == "gmt_globe") {
oceDebug(debug, "case 1.3: built-in gmt_globe\n")
# $Id: GMT_globe.cpt,v 1.1 2001/09/23 23:11:20 pwessel Exp $
#
# Colormap using in global relief maps
# Bathymetry colors manually redefined for blue-shade effect and
# new topography color scheme for use with Generic Mapping Tools.
# Designed by Lester M. Anderson (CASP, UK) lester.anderson@casp.cam.ac.uk
# COLOR_MODEL = RGB
text <- "-10000 153 0 255 -9500 153 0 255
-9500 153 0 255 -9000 153 0 255
-9000 153 0 255 -8500 153 0 255
-8500 136 17 255 -8000 136 17 255
-8000 119 34 255 -7500 119 34 255
-7500 102 51 255 -7000 102 51 255
-7000 85 68 255 -6500 85 68 255
-6500 68 85 255 -6000 68 85 255
-6000 51 102 255 -5500 51 102 255
-5500 34 119 255 -5000 34 119 255
-5000 17 136 255 -4500 17 136 255
-4500 0 153 255 -4000 0 153 255
-4000 27 164 255 -3500 27 164 255
-3500 54 175 255 -3000 54 175 255
-3000 81 186 255 -2500 81 186 255
-2500 108 197 255 -2000 108 197 255
-2000 134 208 255 -1500 134 208 255
-1500 161 219 255 -1000 161 219 255
-1000 188 230 255 -500 188 230 255
-500 215 241 255 -200 215 241 255
-200 241 252 255 0 241 252 255
0 51 102 0 100 51 204 102
100 51 204 102 200 187 228 146
200 187 228 146 500 255 220 185
500 255 220 185 1000 243 202 137
1000 243 202 137 1500 230 184 88
1500 230 184 88 2000 217 166 39
2000 217 166 39 2500 168 154 31
2500 168 154 31 3000 164 144 25
3000 164 144 25 3500 162 134 19
3500 162 134 19 4000 159 123 13
4000 159 123 13 4500 156 113 7
4500 156 113 7 5000 153 102 0
5000 153 102 0 5500 162 89 89
5500 162 89 89 6000 178 118 118
6000 178 118 118 6500 183 147 147
6500 183 147 147 7000 194 176 176
7000 194 176 176 7500 204 204 204
7500 204 204 204 8000 229 229 229
8000 229 229 229 8500 242 242 242
8500 242 242 242 9000 255 255 255
9000 255 255 255 9500 255 255 255
9500 255 255 255 10000 255 255 255
F 255 255 255
B 0 0 0
N 128 128 128"
} else if (name == "gmt_gebco") {
oceDebug(debug, "case 1.4: built-in gmt_gebco\n")
# $Id: GMT_gebco.cpt,v 1.1.1.1 2000/12/28 01:23:45 gmt Exp $
#
# Bathymetry colors approximating the GEBCO charts
# Designed by Andrew Goodwillie, Scripps
# COLOR_MODEL = RGB
text <- "-7000 0 240 255 -6000 0 240 255
-6000 35 255 255 -5000 35 255 255
-5000 90 255 255 -4000 90 255 255
-4000 140 255 230 -3000 140 255 230
-3000 165 255 215 -2000 165 255 215
-2000 195 255 215 -1000 195 255 215
-1000 210 255 215 -500 210 255 215
-500 230 255 240 -200 230 255 240
-200 235 255 255 -0 235 255 255
F 255 255 255
B 0 0 0
N 128 128 128"
}
text <- gsub("^[ ]*", "", strsplit(text, "\\n")[[1]])
} else {
oceDebug(debug, "case 2: file or URL\n")
# Look for local file or URL
text <- try(readLines(name), silent=TRUE)
if (inherits(text, "try-error"))
stop("unknown colormap name: \"", name, "\" (not built-in, not local file, not working URL)")
}
text <- text[!grepl("^#", text)] # remove comments, if any exist (as in files read in)
textData <- text[grep("^[ ]*[-0-9]", text)]
textData <- gsub("/", " ", textData) # sometimes it is R/G/B
d <- read.table(text=textData, col.names=c("x0", "r0", "g0", "b0", "x1", "r1", "g1", "b1"))
col0 <- rgb(d$r0, d$g0, d$b0, maxColorValue=255)
col1 <- rgb(d$r1, d$g1, d$b1, maxColorValue=255)
# Decode (F, B) and N=missingColor. Note step by step approach,
# which may be useful in debugging different formats, e.g.
# tabs and spaces etc.
# "F" unused at present
# nolint start T_and_F_symbol_linter
F <- "#FFFFFF"
if (length(grep("^\\sF", text))) {
line <- text[grep("\\s*F", text)]
line <- gsub("^\\sF", "", line)
F <- scan(text=line, quiet=TRUE)
Flen <- length(F)
if (1 == Flen) {
F <- if (length(grep("[a-zA-Z]", F))) F else gray(as.numeric(F) / 255)
} else if (3 == Flen) {
F <- rgb(F[1], F[2], F[3], maxColorValue=255)
} else {
warning("cannot decode \"F\" from \"", line, "\"")
}
}
# nolint end T_and_F_symbol_linter
# "B" unused at present
B <- "#000000"
if (length(grep("^\\sB", text))) {
line <- text[grep("\\s*B", text)]
line <- gsub("^\\sB", "", line)
B <- scan(text=line, quiet=TRUE)
Blen <- length(B)
if (1 == Blen) {
B <- if (length(grep("[a-zA-Z]", B))) B else gray(as.numeric(B) / 255)
} else if (3 == Blen) {
B <- rgb(B[1], B[2], B[3], maxColorValue=255)
} else {
warning("cannot decode \"B\" from \"", line, "\"")
}
}
# "N" named here as missingColor to match e.g. imagep()
N <- "gray"
if (length(grep("^\\s*N", text))) {
line <- text[grep("^\\s*N", text)]
line <- gsub("\\s*N", "", line)
N <- scan(text=line, what=character(), quiet=TRUE)
Nlen <- length(N)
if (1 == Nlen) {
N <- if (length(grep("[a-zA-Z]", N))) N else gray(as.numeric(N) / 255)
} else if (3 == Nlen) {
N <- rgb(N[1], N[2], N[3], maxColorValue=255)
} else {
warning("cannot decode missingColor from \"", line, "\"")
}
}
col <- head(rgb(d$r0, d$g0, d$b0, maxColorValue=255L), -1L)
#colbreaks <- colormapGmtNumeric(d$x0, d$x1, d$col0, d$col1)
res <- list(x0=d$x0, x1=d$x1, col0=col0, col1=col1, breaks=d$x0, col=col, missingColor=N)
class(res) <- c("list", "colormap")
oceDebug(debug, "} # colormapGMT()\n", sep="", unindent=1)
res
}
#' Calculate color map
#'
#' Create a mapping between numeric values and colors, for use in palettes and plots.
#' The return value can be used in various ways, including colorizing points
#' on scattergraphs, controlling images created by [image()] or [imagep()],
#' drawing palettes with [drawPalette()], etc.
#'
#' `colormap` can be used in a variety of ways, including the following.
#'
#' * **Case A.** Supply some combination of arguments that
#' is sufficient to define a mapping of value to color, without
#' providing `x0`, `col0`, `x1` or `col1` (see case B for these),
#' or providing `name` (see Case C). There are several ways to
#' do this. One approach is to supply `z` but no
#' other argument, in which case `zlim`, and `breaks` will be determined
#' from `z`, and the default `col` will be used. Another approach is
#' to specify `breaks` and `col` together, in the same way as they
#' might be specified for the base R function [image()]. It is
#' also possible to supply only `zlim`, in which case `breaks` is
#' inferred from that value.
#' \if{html}{The figure below explains the
#' (`breaks`, `col`) method of specifying a color mapping. Note
#' that there must be one more break than color. This is the method used by
#' e.g. [image()].}
#' \if{html}{\figure{colormap_fig_1.png}}
#'
#' * **Case B.** Supply `x0`, `col0`, `x1`, and `col1`, but *not*
#' `zlim`, `breaks`, `col` or `name`.
#' The `x0`, `col0`, `x1` and `col1` values specify a
#' value-color mapping that is similar to that used
#' for GMT color maps. The method works by using [seq()] to
#' interpolate between the elements of the `x0` vector. The same is done
#' for `x1`. Similarly, [colorRampPalette()] is used to
#' interpolate between the colors in the `col0` vector, and the same is
#' done for `col1`. \if{html}{The figure above explains the (`x0`,
#' `x1`, `col0`, `col1`) method of specifying a color mapping.
#' Note that the each of the items has the same length. The case of
#' `blend=0`, which has color `col0[i]` between `x0[i]` and
#' `x1[i]`, is illustrated below.}
#' \if{html}{\figure{colormap_fig_2.png}}
#'
#' * **Case C.** Supply `name` and possibly also `z`, but *not*
#' `zlim`, `breaks`, `col`, `x0`, `col0`, `x1` or `col1`.
#' The `name` may be the name of a pre-defined color palette
#' (`"gmt_relief"`, `"gmt_ocean"`, `"gmt_globe"` or
#' `"gmt_gebco"`), or it may be the name of a file (or URL pointing to a file)
#' that contains a color map in the GMT format (see \dQuote{References}). If
#' `z` is supplied along with `name`, then `zcol` will be set up in the
#' return value, e.g. for use in colorizing points. Another method
#' for finding colors for data points is to use the `colfunction()`
#' function in the return value.
#'
#' @param z an optional vector or other set of numerical values to be examined.
#' If `z` is given, the return value will contain an item named
#' `zcol` that will be a vector of the same length as `z`, containing
#' a color for each point. If `z` is not given, `zcol` will contain
#' just one item, the color `"black"`.
#'
#' @param zlim optional vector containing two numbers that specify the `z`
#' limits for the color scale. This can only be provided in cases A
#' and B, as defined in \dQuote{Details}. For case A, if `zlim` is not
#' provided, then it is inferred by using [rangeExtended()]
#' on `breaks`, if that is provided, or from `z` otherwise. Also,
#' in case A, it is an error to provide both `zlim` and `breaks`,
#' unless the latter is of length 1, meaning the number of
#' subdivisions to use within the range set by `zlim`.
#' In case B, `zlim` is inferred from using [rangeExtended()] on `c(x0,x1)`.
#' In case C, providing `zlim` yields an error message, because it makes no
#' sense in the context of a named, predefined color scheme.
#'
#' @param zclip logical, with `TRUE` indicating that z values outside the
#' range of `zlim` or `breaks` should be painted with
#' `missingColor` and `FALSE` indicating that these values should be
#' painted with the nearest in-range color.
#'
#' @param breaks an optional indication of break points between color levels
#' (see [image()]). If this is provided, the arguments `name`
#' through `blend` are all ignored (see \dQuote{Details}). If it is
#' provided, then it may either be a vector of break points, or a single number
#' indicating the desired number of break points to be computed with
#' [`pretty`]`(z,breaks)`. In either case of non-missing
#' `breaks`, the resultant break points must number 1 plus the number of
#' colors (see `col`).
#'
#' @param col either a vector of colors or a function taking a numerical value
#' as its single argument and returning a vector of colors. Prior to 2021-02-08,
#' the default for `col` was `oceColorsJet`, but it was switched to
#' `oceColorsViridis` on that date. The value of
#' `col` is ignored if `name` is provided, or if `x0` through
#' `col1` are provided.
#'
#' @param name an optional string naming a built-in colormap (one of
#' `"gmt_relief"`, `"gmt_ocean"`, `"gmt_globe"` or
#' `"gmt_gebco"`) or the name of a file or URL that contains a color map
#' specification in GMT format. If `name` is given, then it is
#' passed to [colormapGMT()], which creates the colormap.
#' Note that the colormap thus created has a fixed
#' relationship between value and color, and `zlim`,
#` `z0`, etc. are ignored when `name` is provided. Indeed, the
#' only other argument that is examined is `z` (which may be used
#' so that `zcol` will be defined in the return value), and warnings
#' are issued if some irrelevant arguments are provided.
#'
#' @param x0,x1,col0,col1 Vectors that specify a color map. They must all be
#' the same length, with `x0` and `x1` being numerical values, and
#' `col0` and `col1` being colors. The colors may be strings (e.g.
#' `"red"`) or colors as defined by [rgb()] or [hsv()].
#'
#' @param blend a number indicating how to blend colors within each band.
#' This is ignored except when `x0` through `col1` are supplied. A
#' value of 0 means to use `col0[i]` through the interval `x0[i]` to
#' `x1[i]`. A value of 1 means to use `col1[i]` in that interval. A
#' value between 0 and 1 means to blend between the two colors according to
#' the stated fraction. Values exceeding 1 are an error at present, but there
#' is a plan to use this to indicate sub-intervals, so a smooth palette can be
#' created from a few colors.
#'
#' @param missingColor color to use for missing values. This cannot be provided
#' if `name` is also provided (case C), because named schemes have pre-defined
#' colors. For other cases, `missingColor` defaults to `"gray"`, if it
#' is not provided as an argument.
#'
#' @param debug a flag that turns on debugging. Set to 1 to get a moderate
#' amount of debugging information, or to 2 to get more.
#'
#' @return a list containing the following (not necessarily in this order)
#'
#' * `zcol`, a vector of colors for `z`, if `z` was
#' provided, otherwise `"black"`
#'
#' * `zlim`, a two-element vector suitable as the argument of the same
#' name supplied to [image()] or [imagep()]
#'
#' * `breaks` and `col`, vectors of breakpoints and colors,
#' suitable as the same-named arguments to [image()] or
#' [imagep()]
#'
#' * `zclip` the provided value of `zclip`.
#'
#' * `x0` and `x1`, numerical vectors of the sides of color
#' intervals, and `col0` and `col1`, vectors of corresponding
#' colors. The meaning is the same as on input. The purpose of returning
#' these four vectors is to permit users to alter color mapping, as in example
#' 3 in \dQuote{Examples}.
#'
#' * `missingColor`, a color that could be used to specify missing
#' values, e.g. as the same-named argument to [imagep()].
#'
#' * `colfunction`, a univariate function that returns a vector
#' of colors, given a vector of `z` values; see Example 6.
#'
#' @author Dan Kelley
#'
#' @examples
#' library(oce)
#' # Example 1. color scheme for points on xy plot
#' x <- seq(0, 1, length.out=40)
#' y <- sin(2 * pi * x)
#' par(mar=c(3, 3, 1, 1))
#' mar <- par('mar') # prevent margin creep by drawPalette()
#' # First, default breaks
#' c <- colormap(y)
#' drawPalette(c$zlim, col=c$col, breaks=c$breaks)
#' plot(x, y, bg=c$zcol, pch=21, cex=1)
#' grid()
#' par(mar=mar)
#' # Second, 100 breaks, yielding a smoother palette
#' c <- colormap(y, breaks=100)
#' drawPalette(c$zlim, col=c$col, breaks=c$breaks)
#' plot(x, y, bg=c$zcol, pch=21, cex=1)
#' grid()
#' par(mar=mar)
#'
#'\dontrun{
#' # Example 2. topographic image with a standard color scheme
#' par(mfrow=c(1,1))
#' data(topoWorld)
#' cm <- colormap(name="gmt_globe")
#' imagep(topoWorld, breaks=cm$breaks, col=cm$col)
#'
#' # Example 3. topographic image with modified colors,
#' # black for depths below 4km.
#' cm <- colormap(name="gmt_globe")
#' deep <- cm$x0 < -4000
#' cm$col0[deep] <- 'black'
#' cm$col1[deep] <- 'black'
#' cm <- colormap(x0=cm$x0, x1=cm$x1, col0=cm$col0, col1=cm$col1)
#' imagep(topoWorld, breaks=cm$breaks, col=cm$col)
#'
#' # Example 4. image of world topography with water colorized
#' # smoothly from violet at 8km depth to blue
#' # at 4km depth, then blending in 0.5km increments
#' # to white at the coast, with tan for land.
#' cm <- colormap(x0=c(-8000, -4000, 0, 100),
#' x1=c(-4000, 0, 100, 5000),
#' col0=c("violet","blue","white","tan"),
#' col1=c("blue","white","tan","yellow"))
#' lon <- topoWorld[['longitude']]
#' lat <- topoWorld[['latitude']]
#' z <- topoWorld[['z']]
#' imagep(lon, lat, z, breaks=cm$breaks, col=cm$col)
#' contour(lon, lat, z, levels=0, add=TRUE)
#'
#' # Example 5. visualize GMT style color map
#' cm <- colormap(name="gmt_globe", debug=4)
#' plot(seq_along(cm$x0), cm$x0, pch=21, bg=cm$col0)
#' grid()
#' points(seq_along(cm$x1), cm$x1, pch=21, bg=cm$col1)
#'
#' # Example 6. colfunction
#' cm <- colormap(c(0, 1))
#' x <- 1:10
#' y <- (x - 5.5)^2
#' z <- seq(0, 1, length.out=length(x))
#' drawPalette(colormap=cm)
#' plot(x, y, pch=21, bg=cm$colfunction(z), cex=3)
#'}
#'
#' @family things related to colors
#'
#' @template colourBlindnessTemplate
colormap <- function(z=NULL, zlim, zclip=FALSE, breaks, col=oceColorsViridis,
name, x0, x1, col0, col1, blend=0, missingColor, debug=getOption("oceDebug"))
{
debug <- min(max(0, debug), 1)
#oceDebug(debug, gsub(" = [^,)]*", "", deparse(expr=match.call())), " {\n", style="bold", sep="", unindent=1)
oceDebug(debug, "colormap(...) {\n", sep="", style="bold", unindent=1)
zKnown <- !is.null(z)
zlimKnown <- !missing(zlim)
breaksKnown <- !missing(breaks)
# nolint start object_usage_linter
colKnown <- !missing(col)
# nolint end object_usage_linter
nameKnown <- !missing(name)
x0Known <- !missing(x0)
x1Known <- !missing(x1)
col0Known <- !missing(col0)
col1Known <- !missing(col1)
missingColorKnown <- !missing(missingColor)
# Sanity checks on args
if (blend < 0 || blend > 1)
stop("blend must be between 0 and 1")
if (zlimKnown) {
if (length(zlim) != 2)
stop("'zlim' must be of length 2")
if (any(!is.finite(zlim)))
stop("'zlim' values must be finite")
if (zlim[2] <= zlim[1])
stop("'zlim' values must be ordered and distinct")
}
if (zlimKnown && breaksKnown && length(breaks) > 1)
stop("cannot specify both zlim and breaks, unless length(breaks)==1")
# Find cases (as a way to clarify code, and link it with the docs).
if (nameKnown) {
case <- "C"
} else if (x0Known || col0Known || x1Known || col1Known) {
case <- "B"
} else if (zKnown || zlimKnown || breaksKnown) {
case <- "A"
} else {
case <- "A"
warning("defaulting to case A, which may be incorrect\n")
}
# Case C: 'name' was given: only 'name' and possibly 'z' are examined.
if (case == "C") {
oceDebug(debug, "Case C: name given\n", style="bold")
for (disallowed in c("zlim", "breaks", "col", "x0", "col0", "x1", "col1", "missingColor")) {
if (get(paste0(disallowed, "Known")))
stop("cannot supply '", disallowed, "' since 'name' was supplied (i.e. in Case C)\n")
}
res <- colormap_colormap(name=name, debug=debug-1)
res$zclip <- zclip
res$zlim <- range(c(res$x0, res$x1)) # ignore argument 'zlim'
res$colfunction <- function(z) res$col0[findInterval(z, res$x0, all.inside=TRUE)]
if (zKnown) {
res$zcol <- res$colfunction(z)
}
oceDebug(debug, "} # colormap() case C\n", style="bold", sep="", unindent=1)
return(res)
} # end of case C
if (case == "B") { # x0 col0 x1 col1
oceDebug(debug, "Case B\n", style="bold")
if (!(x0Known && col0Known && x1Known && col1Known))
stop("'x0', 'col0', 'x1', 'col1' must all be supplied, if any is supplied")
for (disallowed in c("name", "breaks", "col")) {
if (get(paste0(disallowed, "Known"))) {
stop("cannot supply '", disallowed, "' since `x0`, `col0`, `x1` and `col1` were supplied (i.e. in Case B)\n")
}
}
if (length(x0) != length(x1))
stop("lengths of x0 and x1 must agree")
if (length(col0) != length(col1))
stop("lengths of col0 and col1 must agree")
if (length(x0) != length(col0))
stop("lengths of x0 and col0 must agree")
if (!identical(x0, sort(x0)))
stop("'x0' must be ordered from small to large")
if (!identical(x1, sort(x1)))
stop("'x1' must be ordered from small to large")
breaks <- c(x0, tail(x1, 1))
# blend colors
col <- col2rgb(col0) # will overwrite
oceDebug(debug, "blend=", blend, "\n", sep="")
for (i in seq_along(col0))
col[, i] <- colorRamp(c(col0[i], col1[i]))(blend)[1, ]
col <- rgb(col[1, ], col[2, ], col[3, ], maxColorValue=255)
if (!missingColorKnown)
missingColor <- "gray"
if (zKnown) {
# BOOKMARK1 -- this code needs to be in synch with BOOKMARK2
i <- findInterval(z, breaks)
missing <- i == 0
i[missing] <- 1 # just pick something; replaced later
zcol <- col[i]
zcol[missing] <- missingColor
if (zclip) {
zcol[missing] <- missingColor
} else {
if (zKnown)
zcol[is.na(z)] <- missingColor
zcol[z <= min(breaks)] <- col[1]
zcol[z >= max(breaks)] <- tail(col, 1)
}
} else {
zcol <- "black"
}
res <- list(x0=x0, x1=x1, col0=col0, col1=col1, missingColor=missingColor,
zclip=zclip, zlim=if (zlimKnown) zlim else rangeExtended(c(x0, x1)),
breaks=breaks, col=col, zcol=zcol)
class(res) <- c("list", "colormap")
oceDebug(debug, "} # colormap() case B\n", style="bold", sep="", unindent=1)
return(res)
} # end of case B
oceDebug(debug, "case 3: name not given, x0 (and related) not given\n")
if (!zlimKnown) {
if (breaksKnown) {
oceDebug(debug, "zlimKnown=", zlimKnown, ", so inferring zlim from breaks\n", sep="")
zlim <- if (length(breaks) > 1) range(breaks) else NULL
zlimKnown <- TRUE
} else if (zKnown) {
oceDebug(debug, "zlimKnown=", zlimKnown, ", so inferring zlim from z\n", sep="")
if (!any(is.finite(z)))
stop("cannot infer zlim, since z has no finite values, and breaks was not given")
zlim <- rangeExtended(z[is.finite(z)])
zlimKnown <- TRUE
} else {
stop("cannot infer zlim; please specify zlim, breaks, name, or z")
}
}
oceDebug(debug, "zlim=", if (is.null(zlim)) "NULL" else zlim, "\n")
oceDebug(debug, "zclip=", zclip, "\n")
blend <- max(blend, 0L)
n <- if (blend > 1L) as.integer(round(blend)) else 1L
oceDebug(debug, "blend=", blend, "; n=", n, "\n", sep="")
# Possibly determine breaks, if not given but if can be inferred from z or zlim
if (!breaksKnown) {
if (zlimKnown) {
oceDebug(debug, "case 3.1 breaks not given, but inferred from zlim\n")
breaks <- seq(min(zlim, na.rm=TRUE), max(zlim, na.rm=TRUE), length.out=255)
oceDebug(debug, "created", length(breaks), "breaks, ranging from", breaks[1], "to", tail(breaks, 1), "\n")
breaksKnown <- TRUE # this makes next block execute also
} else if (zKnown && any(is.finite(z))) {
oceDebug(debug, "case 3.2 breaks not given, but inferred from z\n")
breaks <- seq(min(z, na.rm=TRUE), max(z, na.rm=TRUE), length.out=255)
oceDebug(debug, "created", length(breaks), "breaks, ranging from", breaks[1], "to", tail(breaks, 1), "\n")
breaksKnown <- TRUE
}
}
if (breaksKnown) {
oceDebug(debug, "case 4 breaks given, or inferred from either z or zlim\n")
if (zKnown) {
oceDebug(debug, "case 4.1 construct colormap using z\n")
if (length(breaks) < 2) {
breaks <- seq(min(z, na.rm=TRUE), max(z, na.rm=TRUE), length.out=breaks)
oceDebug(debug, "constructing breaks from z as ", paste(breaks, collapse=" "), "\n")
}
if (missing(missingColor)) {
res <- colormap_colorize(zlim=zlim, zclip=zclip, z=z, breaks=breaks, col=col,
debug=debug-1)
} else {
res <- colormap_colorize(zlim=zlim, zclip=zclip, z=z, breaks=breaks, col=col,
missingColor=missingColor, debug=debug-1)
}
} else {
oceDebug(debug, "case 4.2 construct colormap using zlim\n")
oceDebug(debug, "length(breaks)=", length(breaks), "\n", sep="")
if (length(breaks) < 2) {
breaks <- seq(zlim[1], zlim[2], length.out=breaks)
oceDebug(debug, "constructing breaks from zlim as ", paste(breaks, collapse=" "), "\n")
}
if (missing(missingColor)) {
res <- colormap_colorize(zlim=zlim, zclip=zclip, breaks=breaks, col=col, debug=debug-1)
} else {
res <- colormap_colorize(zlim=zlim, zclip=zclip, breaks=breaks, col=col, missingColor=missingColor, debug=debug-1)
}
res$zcol <- "black"
}
res$x0 <- res$breaks[-1]
res$x1 <- res$breaks[-1]
res$col0 <- res$col
res$col1 <- res$col
}
res$missingColor <- if (missingColorKnown) missingColor else "gray"
res$zclip <- zclip
res$colfunction <- function(z) res$col0[findInterval(z, res$x0)]
class(res) <- c("list", "colormap")
oceDebug(debug, "} # colormap() case A\n", style="bold", sep="", unindent=1)
res
}
# keeping this (which was called 'colormap' until 2014-05-07), but not in NAMESPACE.
colormap_colormap <- function(name, x0, x1, col0, col1, n=1, zclip=FALSE, debug=getOption("oceDebug"))
{
nameKnown <- !missing(name)
oceDebug(debug, "colormap_colormap(name=",
if (nameKnown) paste0("\"", name, "\"") else "(MISSING)",
", ...) {\n", sep="", unindent=1)
if (nameKnown) {
oceDebug(debug, "name was specified, so using colormapGMT() to compute colormap\n")
res <- colormapGMT(name, debug=debug-1)
} else {
oceDebug(debug, "name was not specified, so using x0, x1, etc., to compute colormap\n")
if (missing(x0) || missing(x1) || missing(col0) || missing(col1))
stop('give either "name" or all of: "x0", "x1", "col0" and "col1"')
xlen <- length(x0)
if (length(x1) != xlen)
stop('lengths of "x0" and "x1" must agree')
if (length(col0) != xlen)
stop('lengths of "x0" and "col0" must agree')
if (length(col1) != xlen)
stop('lengths of "x0" and "col1" must agree')
x0r <- x1r <- col0r <- col1r <- NULL
if (length(n) != xlen - 1)
n <- rep(n[1], length.out=xlen)
oceDebug(debug, "x0:", x0, "\n")
oceDebug(debug, "x1:", x1, "\n")
oceDebug(debug, "col0:", col0, "\n")
oceDebug(debug, "col1:", col1, "\n")
#x0A <- c(x0, tail(x1, 1))
for (i in 2:xlen) {
dx0 <- (x0[i] - x0[i-1]) / n[i-1]
x0r <- c(x0r, seq(x0[i-1], by=dx0, length.out=n[i-1]))
dx1 <- (x1[i] - x1[i-1]) / n[i-1]
x1r <- c(x1r, seq(x1[i-1], by=dx1, length.out=n[i-1]))
col0r <- c(col0r, colorRampPalette(col0[seq.int(i-1, i)])(n[i-1]))
col1r <- c(col1r, colorRampPalette(col1[seq.int(i-1, i)])(n[i-1]))
oceDebug(debug, "i=", i, "\n")
oceDebug(debug, " x0[i-1]", x0[i-1], "x0[i]", x0[i], "\n")
oceDebug(debug, " concat x0:", seq(x0[i-1], by=dx0, length.out=1+n[i-1]), "\n")
oceDebug(debug, " col0[i-1]:", col0[i-1], "col0[i]:", col0[i], "\n")
oceDebug(debug, " col1[i-1]:", col1[i-1], "col1[i]:", col1[i], "\n")
}
# next is wrong -- should not just tack on one value unless n=1
x0r <- c(x0r, tail(x0, 1))
x1r <- c(x1r, tail(x1, 1))
col0r <- c(col0r, tail(col0, 1))
col1r <- c(col1r, tail(col1, 1))
res <- list(x0=x0r, x1=x1r, col0=col0r, col1=col1r)
}
res$zclip <- zclip
class(res) <- c("list", "colormap")
oceDebug(debug, "} # colormap_colormap()\n", sep="", unindent=1)
res
}
# internal function for palettes
palette2breakscolor <- function(name, breaksPerLevel=1, topoRegion=c("water", "land", "both"))
{
knownPalettes <- c("GMT_relief", "GMT_ocean", "globe")
palette <- pmatch(name, knownPalettes)
if (is.na(palette))
stop("unknown palette name \"", name, "\"")
name <- knownPalettes[palette]
if (name == "GMT_relief") {
# GMT based on
# GMT_relief.cpt,v 1.1 2001/09/23 23:11:20 pwessel Exp $
d <- list(l=1000*c(-8, -7, -6, -5, -4, -3, -2, -1, 0, 0.5, 1, 2, 3, 4, 5, 6, 7),
lr=c(0, 0, 0, 0, 0, 86, 172, 211, 70, 120, 146, 198, 250, 250, 252, 252, 253),
lg=c(0, 5, 10, 80, 150, 197, 245, 250, 120, 100, 126, 178, 230, 234, 238, 243, 249),
lb=c(0, 25, 50, 125, 200, 184, 168, 211, 50, 50, 60, 80, 100, 126, 152, 177, 216),
u=1000*c(-7, -6, -5, -4, -3, -2, -1, 0, 0.5, 1, 2, 3, 4, 5, 6, 7, 8),
ur=c(0, 0, 0, 0, 86, 172, 211, 250, 120, 146, 198, 250, 250, 252, 252, 253, 255),
ug=c(5, 10, 80, 150, 197, 245, 250, 255, 100, 126, 178, 230, 234, 238, 243, 249, 255),
ub=c(25, 50, 125, 200, 184, 168, 211, 255, 50, 60, 80, 100, 126, 152, 177, 216, 255),
f="#FFFFFF",
b="#000000",
n="#FFFFFF")
} else if (name == "GMT_ocean") {
d <- list(l=1000*c(-8, -7, -6, -5, -4, -3, -2, -1),
lr=c(0, 0, 0, 0, 0, 86, 172, 211),
lg=c(0, 5, 10, 80, 150, 197, 245, 250),
lb=c(0, 25, 50, 125, 200, 184, 168, 211),
u=1000*c(-7, -6, -5, -4, -3, -2, -1, 0),
ur=c(0, 0, 0, 0, 0, 86, 172, 211, 250),
ug=c(5, 10, 80, 150, 197, 245, 250, 255),
ub=c(25, 50, 125, 200, 184, 168, 211, 255),
f="#FFFFFF",
b="#000000",
n="#FFFFFF")
} else if (name == "globe") {
# nolint start (long lines)
d <- list(
l=1000*c(-10, -9.5, -9, -8.5, -8, -7.5, -7, -6.5, -6, -5.5, -5, -4.5, -4, -3.5, -3, -2.5, -2, -1.5, -1, -0.5, -0.2, 0, 0.1, 0.2, 0.5, 1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, 9, 9.5),
lr=c(153, 153, 153, 136, 119, 102, 85, 68, 51, 34, 17, 0, 27, 54, 81, 108, 134, 161, 188, 215, 241, 51, 51, 187, 255, 243, 230, 217, 168, 164, 162, 159, 156, 153, 162, 178, 183, 194, 204, 229, 242, 255, 255),
lg=c(0, 0, 0, 17, 34, 51, 68, 85, 102, 119, 136, 153, 164, 175, 186, 197, 208, 219, 230, 241, 252, 102, 204, 228, 220, 202, 184, 166, 154, 144, 134, 123, 113, 102, 89, 118, 147, 176, 204, 229, 242, 255, 255),
lb=c(255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 0, 102, 146, 185, 137, 88, 39, 31, 25, 19, 13, 7, 0, 89, 118, 147, 176, 204, 229, 242, 255, 255),
u=1000*c(-9.5, -9, -8.5, -8, -7.5, -7, -6.5, -6, -5.5, -5, -4.5, -4, -3.5, -3, -2.5, -2, -1.5, -1, -0.5, -0.2, 0, 0.1, 0.2, 0.5, 1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, 9, 9.5, 10),
ur=c(153, 153, 153, 136, 119, 102, 85, 68, 51, 34, 17, 0, 27, 54, 81, 108, 134, 161, 188, 215, 241, 51, 187, 255, 243, 230, 217, 168, 164, 162, 159, 156, 153, 162, 178, 183, 194, 204, 229, 242, 255, 255, 255),
ug=c(0, 0, 0, 17, 34, 51, 68, 85, 102, 119, 136, 153, 164, 175, 186, 197, 208, 219, 230, 241, 252, 204, 228, 220, 202, 184, 166, 154, 144, 134, 123, 113, 102, 89, 118, 147, 176, 204, 229, 242, 255, 255, 255),
ub=c(255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 102, 146, 185, 137, 88, 39, 31, 25, 19, 13, 7, 0, 89, 118, 147, 176, 204, 229, 242, 255, 255, 255),
f="#FFFFFF",
b="#000000",
n="#808080")
# nolint end (long lines)
} else {
stop("'", palette, "' is not a recognized value for 'palette'")
}
nlevel <- length(d$l)
breaks <- NULL
col <- NULL
for (l in 1:nlevel) {
lowerColor <- rgb(d$lr[l]/255, d$lg[l]/255, d$lb[l]/255)
upperColor <- rgb(d$ur[l]/255, d$ug[l]/255, d$ub[l]/255)
breaks <- c(breaks, seq(d$l[l], d$u[l], length.out=1+breaksPerLevel))
col <- c(col, colorRampPalette(c(lowerColor, upperColor))(1+breaksPerLevel))
}
if (palette %in% c("GMT_relief")) {
if (topoRegion == "water") {
wet <- breaks <= 0
breaks <- breaks[wet]
col <- col[wet]
} else if (topoRegion == "land") {
dry <- breaks >= 0
breaks <- breaks[dry]
col <- col[dry]
}
}
# remove last color since must have 1 more break than color
col <- head(col, -1)
list(breaks=breaks, col=col, f=d$f, b=d$b, n=d$n)
}
Try the oce package in your browser
Any scripts or data that you put into this service are public.
oce documentation built on July 9, 2023, 5:18 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions palette2breakscolor colormap_colormap colormap colormapGMT colormapGmtNumeric colormap_colorize
Documented in colormap colormapGMT
# vim: tw=80 shiftwidth=4 softtabstop=4 wrap linebreak expandtab:
#' Data that define some color palettes
#'
#' The `ocecolors` dataset is a list containing color-schemes, used
#' by [oceColorsClosure()] to create functions such as
#' [oceColorsViridis()].
#'
#' @name ocecolors
#'
#' @docType data
#' @author Authored by matplotlib contributers, packaged (with license permission) in oce by Dan Kelley
#'
#' @source The data come from the matplotlib site
#' `https://github.com/matplotlib/matplotlib`.
#'
#' @template colourBlindnessTemplate
#'
#' @family datasets provided with oce
#' @family things related to colors
#'
#' @template colourBlindnessTemplate
NULL
colormapNames <- c("gmt_relief", "gmt_ocean", "gmt_globe", "gmt_gebco")
# keeping this (which was called 'colorize' until 2014-05-07) for a while, but not in NAMESPACE.
colormap_colorize <- function(z=NULL, zlim, zclip=FALSE, breaks,
col=oceColorsViridis, colormap=NULL, segments=1, missingColor="gray",
debug=getOption("oceDebug"))
{
oceDebug(debug, "colormap_colorize(z=",
if (is.null(z)) "(missing)" else paste("c(", z[1], ",...)", sep=""), ",",
"zlim=", if (missing(zlim)) "(missing)" else
paste("c(", zlim[1], ",", zlim[2], "),", sep=""),
"zclip=", zclip, ",",
"breaks=", if (missing(breaks)) "(missing)" else
paste("c(", breaks[1], ",...),", sep=""),
"col=", if (is.function(col)) "(function)" else paste("c(", col[1], ",...)", sep=""), ",",
"colormap=", if (is.null(colormap)) "(missing)" else colormap, ",",
"segments=", segments, ",",
"missingColor=", missingColor,
") { # an internal function\n", sep="", unindent=1)
if (is.null(colormap)) {
if (is.function(col)) {
oceDebug(debug, "col is a function\n")
if (missing(breaks)) {
if (!missing(zlim)) {
breaks <- seq(zlim[1], zlim[2], length.out=200)
} else if (!is.null(z)) {
breaks <- seq(min(z, na.rm=TRUE), max(z, na.rm=TRUE), length.out=200)
} else {
stop("must give z, zlim or breaks")
}
}
if (length(breaks) == 1) {
# special case: 'breaks' means *number* of breaks
if (!missing(zlim) && !is.null(zlim)) {
breaks <- seq(zlim[1], zlim[2], length.out=breaks)
#message("pretty(zlim)")
} else if (!is.null(z)) {
breaks <- pretty(z, n=breaks) # note use of pretty(), which extends from data
#message("pretty(z)")
} else {
stop("must give z or zlim if length(breaks)=1")
}
}
col <- col(length(breaks) - 1)
} else {
# FIXME: should check that it is indeed a color, but how?
col <- col
}
if (is.null(z)) {
oceDebug(debug, "z is NULL\n")
if (missing(zlim) || is.null(zlim))
zlim <- range(breaks)
zcol <- "black"
} else {
oceDebug(debug, "z is not NULL\n")
if (missing(zlim) || is.null(zlim)) {
zlim <- rangeExtended(z) # note the extended range
oceDebug(debug, "zlim not given; calculated as:", paste(zlim, collapse=" "), "\n")
}
i <- findInterval(z, breaks)
tooLow <- i == 0
tooHigh <- i == length(breaks)
i[tooLow] <- 1 # cannot index to 0; col is replaced later
zcol <- col[i]
if (zclip) {
oceDebug(debug, "zclip TRUE: out-of-range get missingColor:", missingColor, "\n")
zcol[tooLow] <- missingColor
zcol[tooHigh] <- missingColor
} else {
oceDebug(debug, "zclip FALSE: out-of-range get end colors\n")
zcol[tooLow] <- col[1]
zcol[tooHigh] <- tail(col, 1)
}
}
} else {
# have a colormap
if (!missing(col))
stop("cannot supply 'col' and 'colormap' at the same time")
if (!missing(breaks))
stop("cannot supply 'breaks' and 'colormap' at the same time")
if (is.character(colormap)) {
colormap <- colormap_colormap(name=colormap, debug=debug-1)
if (missing(zlim))
zlim <- colormap$zlim
missingColor <- colormap$missingColor
}
if (inherits(colormap, "colormap"))
missingColor <- colormap$missingColor
breaks <- NULL
col <- NULL
# Could preallocate but colormaps are small so do not bother
n <- length(colormap$x0)
for (i in seq.int(1, n-1)) {
# FIXME: should below be segments or 1+segments?
delta <- (colormap$x0[i+1] - colormap$x0[i]) / segments
breaks <- c(breaks, seq(from=colormap$x0[i], by=delta, length.out=segments))
col <- c(col, colorRampPalette(c(colormap$col0[i], colormap$col1[i]))(segments))
}
nbreaks <- length(breaks)
# extend a bit to the right
delta <- mean(diff(breaks[1:2])) / 1000
breaks <- c(breaks, breaks[nbreaks] + delta)
# FIXME: next might miss top color
if (is.null(zlim)) {
zlim <- if (is.null(z)) range(breaks)
else rangeExtended(z) # note the extended range
}
if (is.null(z)) {
zcol <- "black"
} else {
zlim <- rangeExtended(z)
i <- findInterval(z, breaks)
tooLow <- i == 0
tooHigh <- i == length(breaks)
i[tooLow] <- 1 # cannot index to 0; col is replaced later
zcol <- col[i]
if (zclip) {
oceDebug(debug, "zclip TRUE: out-of-range get missingColor:", missingColor, "\n")
zcol[tooLow] <- missingColor
zcol[tooHigh] <- missingColor
} else {
oceDebug(debug, "zclip FALSE: out-of-range get end colors\n")
zcol[tooLow] <- col[1]
zcol[tooHigh] <- tail(col, 1)
}
}
}
res <- list(zlim=zlim, breaks=breaks, col=col, zcol=zcol, missingColor=missingColor)
class(res) <- c("list", "colormap")
oceDebug(debug, "} # colormap_colorize(), an internal function\n", sep="", unindent=1)
res
}
# NB: I've not documented this, because it is not in the NAMESPACE.
colormapGmtNumeric <- function(x0, x1, col0, col1, bpl=1)
{
n <- length(x0)
if (length(x1) != n)
stop("mismatched lengths of x0 and x1 (", n, " and ", length(x1), ")")
if (length(col0) != n)
stop("mismatched lengths of x0 and col0 (", n, " and ", length(col0), ")")
if (length(col1) != n)
stop("mismatched lengths of x0 and col1 (", n, " and ", length(col1), ")")
breaks <- NULL
col <- NULL
# Could preallocate but colormaps are small so do not bother
for (i in seq.int(1, n-1)) {
breaks <- c(breaks, seq(x0[i], x1[i], length.out=1+bpl))
col <- c(col, colorRampPalette(c(col0[i], col1[i]))(1+bpl))
}
nbreaks <- length(breaks)
# extend a bit to the right
delta <- mean(diff(breaks[1:2])) / 1000
breaks <- c(breaks, breaks[nbreaks] + delta)
res <- list(breaks=breaks, col=col)
res
}
#' Create a GMT-type (CPT) colormap
#'
#' `colormapGMT` creates colormaps in the Generic Mapping Tools (GMT)
#' scheme (see References 1 to 4). A few such schemes are built-in, and may be referred to
#' by name (`"gmt_gebco"`, `"gmt_globe"`, `"gmt_ocean"`, or `"gmt_relief"`)
#' while others are handled by reading local files that are in GMT
#' format, or URLs providing such files (see Reference 3).
#'
#' The GMT files understood by [colormapGMT] are what GMT calls
#' "Regular CPT files" (see reference 4). This is a text format that
#' can be read and (with care) edited in a text editor. There
#' are three categories of lines within this file. (1) Any
#' line starting with the `"#"` character is a comment, and is ignored
#' by [colormapGMT]. (2) Lines with 8 numbers specify colour bands.
#' The first number is a z value, and the three numbers after that
#' are red, green and blue values in the range from 0 to 255. This
#' set of 4 numbers is followed on the same line with similar values.
#' Think of this sequence as describing a band of colours between
#' two z values. (3) Lines starting with a character, followed
#' by three numbers, specify particular codings. The character `"B"`
#' specifies background colour, while `"F"` specifies foreground
#' colour, and `"N"` specifies the colour to be used for missing
#' data (the letter stands for not-a-number). Only `"N"` is used
#' by [colormapGMT], and it takes on the role that the `missingColor`
#' argument would otherwise have. (This is why `missingColor` is not
#' permitted if `name` is given.)
#'
#' @param name character value specifying the GMT scheme, or a source for such
#' a scheme. Four pre-defined schemes are available, accessed by setting `name` to
#' `"gmt_gebco"`, `"gmt_globe"`, `"gmt_ocean"`, or `"gmt_relief"`. If `name` is
#' not one of these values, then it is taken to be the name of a local file
#' in GMT format or, if no such file is found, a URL holding such a file.
#'
#' @param debug integer that, if positive, indicates to print some debugging output
#'
#' @return `colormap` returns a list, in the same format as the return value for [colormap()].
#'
#' @author Dan Kelley
#'
#' @references
#' 1. General overview of GMT system
#' `https://www.generic-mapping-tools.org`.
#' 2. Information on GMT color schemes
#' `https://docs.generic-mapping-tools.org/dev/cookbook/cpts.html`
#' 3. Source of GMT specification files
#' `https://beamreach.org/maps/gmt/share/cpt/`
#' 4. CPT (color palette table) format
#' `https://www.soest.hawaii.edu/gmt/gmt/html/GMT_Docs.html#x1-820004.15`
#'
#' @family things related to colors
colormapGMT <- function(name, debug=getOption("oceDebug"))
{
oceDebug(debug, "colormapGMT(name=\"", name, "...)\n", sep="", unindent=1)
if (name %in% colormapNames) {
oceDebug(debug, "case 1: built-in GMT name\n")
if (name == "gmt_relief") {
oceDebug(debug, "case 1.1: built-in gmt_relief\n")
# $Id: GMT_relief.cpt,v 1.1 2001/09/23 23:11:20 pwessel Exp $
#
# Colortable for whole earth relief used in Wessel topomaps
# Designed by P. Wessel and F. Martinez, SOEST
# COLOR_MODEL = RGB
text <- "-8000 0 0 0 -7000 0 5 25
-7000 0 5 25 -6000 0 10 50
-6000 0 10 50 -5000 0 80 125
-5000 0 80 125 -4000 0 150 200
-4000 0 150 200 -3000 86 197 184
-3000 86 197 184 -2000 172 245 168
-2000 172 245 168 -1000 211 250 211
-1000 211 250 211 0 250 255 255
0 70 120 50 500 120 100 50
500 120 100 50 1000 146 126 60
1000 146 126 60 2000 198 178 80
2000 198 178 80 3000 250 230 100
3000 250 230 100 4000 250 234 126
4000 250 234 126 5000 252 238 152
5000 252 238 152 6000 252 243 177
6000 252 243 177 7000 253 249 216
7000 253 249 216 8000 255 255 255
F 255 255 255
B 0 0 0
N 255 255 255"
} else if (name == "gmt_ocean") {
oceDebug(debug, "case 1.2: built-in gmt_ocean\n")
# $Id: GMT_ocean.cpt,v 1.1 2001/09/23 23:11:20 pwessel Exp $
#
# Colortable for oceanic areas as used in Wessel maps
# Designed by P. Wessel and F. Martinez, SOEST.
# COLOR_MODEL = RGB
text <- "-8000 0 0 0 -7000 0 5 25
-7000 0 5 25 -6000 0 10 50
-6000 0 10 50 -5000 0 80 125
-5000 0 80 125 -4000 0 150 200
-4000 0 150 200 -3000 86 197 184
-3000 86 197 184 -2000 172 245 168
-2000 172 245 168 -1000 211 250 211
-1000 211 250 211 0 250 255 255
F 255 255 255
B 0 0 0"
} else if (name == "gmt_globe") {
oceDebug(debug, "case 1.3: built-in gmt_globe\n")
# $Id: GMT_globe.cpt,v 1.1 2001/09/23 23:11:20 pwessel Exp $
#
# Colormap using in global relief maps
# Bathymetry colors manually redefined for blue-shade effect and
# new topography color scheme for use with Generic Mapping Tools.
# Designed by Lester M. Anderson (CASP, UK) lester.anderson@casp.cam.ac.uk
# COLOR_MODEL = RGB
text <- "-10000 153 0 255 -9500 153 0 255
-9500 153 0 255 -9000 153 0 255
-9000 153 0 255 -8500 153 0 255
-8500 136 17 255 -8000 136 17 255
-8000 119 34 255 -7500 119 34 255
-7500 102 51 255 -7000 102 51 255
-7000 85 68 255 -6500 85 68 255
-6500 68 85 255 -6000 68 85 255
-6000 51 102 255 -5500 51 102 255
-5500 34 119 255 -5000 34 119 255
-5000 17 136 255 -4500 17 136 255
-4500 0 153 255 -4000 0 153 255
-4000 27 164 255 -3500 27 164 255
-3500 54 175 255 -3000 54 175 255
-3000 81 186 255 -2500 81 186 255
-2500 108 197 255 -2000 108 197 255
-2000 134 208 255 -1500 134 208 255
-1500 161 219 255 -1000 161 219 255
-1000 188 230 255 -500 188 230 255
-500 215 241 255 -200 215 241 255
-200 241 252 255 0 241 252 255
0 51 102 0 100 51 204 102
100 51 204 102 200 187 228 146
200 187 228 146 500 255 220 185
500 255 220 185 1000 243 202 137
1000 243 202 137 1500 230 184 88
1500 230 184 88 2000 217 166 39
2000 217 166 39 2500 168 154 31
2500 168 154 31 3000 164 144 25
3000 164 144 25 3500 162 134 19
3500 162 134 19 4000 159 123 13
4000 159 123 13 4500 156 113 7
4500 156 113 7 5000 153 102 0
5000 153 102 0 5500 162 89 89
5500 162 89 89 6000 178 118 118
6000 178 118 118 6500 183 147 147
6500 183 147 147 7000 194 176 176
7000 194 176 176 7500 204 204 204
7500 204 204 204 8000 229 229 229
8000 229 229 229 8500 242 242 242
8500 242 242 242 9000 255 255 255
9000 255 255 255 9500 255 255 255
9500 255 255 255 10000 255 255 255
F 255 255 255
B 0 0 0
N 128 128 128"
} else if (name == "gmt_gebco") {
oceDebug(debug, "case 1.4: built-in gmt_gebco\n")
# $Id: GMT_gebco.cpt,v 1.1.1.1 2000/12/28 01:23:45 gmt Exp $
#
# Bathymetry colors approximating the GEBCO charts
# Designed by Andrew Goodwillie, Scripps
# COLOR_MODEL = RGB
text <- "-7000 0 240 255 -6000 0 240 255
-6000 35 255 255 -5000 35 255 255
-5000 90 255 255 -4000 90 255 255
-4000 140 255 230 -3000 140 255 230
-3000 165 255 215 -2000 165 255 215
-2000 195 255 215 -1000 195 255 215
-1000 210 255 215 -500 210 255 215
-500 230 255 240 -200 230 255 240
-200 235 255 255 -0 235 255 255
F 255 255 255
B 0 0 0
N 128 128 128"
}
text <- gsub("^[ ]*", "", strsplit(text, "\\n")[[1]])
} else {
oceDebug(debug, "case 2: file or URL\n")
# Look for local file or URL
text <- try(readLines(name), silent=TRUE)
if (inherits(text, "try-error"))
stop("unknown colormap name: \"", name, "\" (not built-in, not local file, not working URL)")
}
text <- text[!grepl("^#", text)] # remove comments, if any exist (as in files read in)
textData <- text[grep("^[ ]*[-0-9]", text)]
textData <- gsub("/", " ", textData) # sometimes it is R/G/B
d <- read.table(text=textData, col.names=c("x0", "r0", "g0", "b0", "x1", "r1", "g1", "b1"))
col0 <- rgb(d$r0, d$g0, d$b0, maxColorValue=255)
col1 <- rgb(d$r1, d$g1, d$b1, maxColorValue=255)
# Decode (F, B) and N=missingColor. Note step by step approach,
# which may be useful in debugging different formats, e.g.
# tabs and spaces etc.
# "F" unused at present
# nolint start T_and_F_symbol_linter
F <- "#FFFFFF"
if (length(grep("^\\sF", text))) {
line <- text[grep("\\s*F", text)]
line <- gsub("^\\sF", "", line)
F <- scan(text=line, quiet=TRUE)
Flen <- length(F)
if (1 == Flen) {
F <- if (length(grep("[a-zA-Z]", F))) F else gray(as.numeric(F) / 255)
} else if (3 == Flen) {
F <- rgb(F[1], F[2], F[3], maxColorValue=255)
} else {
warning("cannot decode \"F\" from \"", line, "\"")
}
}
# nolint end T_and_F_symbol_linter
# "B" unused at present
B <- "#000000"
if (length(grep("^\\sB", text))) {
line <- text[grep("\\s*B", text)]
line <- gsub("^\\sB", "", line)
B <- scan(text=line, quiet=TRUE)
Blen <- length(B)
if (1 == Blen) {
B <- if (length(grep("[a-zA-Z]", B))) B else gray(as.numeric(B) / 255)
} else if (3 == Blen) {
B <- rgb(B[1], B[2], B[3], maxColorValue=255)
} else {
warning("cannot decode \"B\" from \"", line, "\"")
}
}
# "N" named here as missingColor to match e.g. imagep()
N <- "gray"
if (length(grep("^\\s*N", text))) {
line <- text[grep("^\\s*N", text)]
line <- gsub("\\s*N", "", line)
N <- scan(text=line, what=character(), quiet=TRUE)
Nlen <- length(N)
if (1 == Nlen) {
N <- if (length(grep("[a-zA-Z]", N))) N else gray(as.numeric(N) / 255)
} else if (3 == Nlen) {
N <- rgb(N[1], N[2], N[3], maxColorValue=255)
} else {
warning("cannot decode missingColor from \"", line, "\"")
}
}
col <- head(rgb(d$r0, d$g0, d$b0, maxColorValue=255L), -1L)
#colbreaks <- colormapGmtNumeric(d$x0, d$x1, d$col0, d$col1)
res <- list(x0=d$x0, x1=d$x1, col0=col0, col1=col1, breaks=d$x0, col=col, missingColor=N)
class(res) <- c("list", "colormap")
oceDebug(debug, "} # colormapGMT()\n", sep="", unindent=1)
res
}
#' Calculate color map
#'
#' Create a mapping between numeric values and colors, for use in palettes and plots.
#' The return value can be used in various ways, including colorizing points
#' on scattergraphs, controlling images created by [image()] or [imagep()],
#' drawing palettes with [drawPalette()], etc.
#'
#' `colormap` can be used in a variety of ways, including the following.
#'
#' * **Case A.** Supply some combination of arguments that
#' is sufficient to define a mapping of value to color, without
#' providing `x0`, `col0`, `x1` or `col1` (see case B for these),
#' or providing `name` (see Case C). There are several ways to
#' do this. One approach is to supply `z` but no
#' other argument, in which case `zlim`, and `breaks` will be determined
#' from `z`, and the default `col` will be used. Another approach is
#' to specify `breaks` and `col` together, in the same way as they
#' might be specified for the base R function [image()]. It is
#' also possible to supply only `zlim`, in which case `breaks` is
#' inferred from that value.
#' \if{html}{The figure below explains the
#' (`breaks`, `col`) method of specifying a color mapping. Note
#' that there must be one more break than color. This is the method used by
#' e.g. [image()].}
#' \if{html}{\figure{colormap_fig_1.png}}
#'
#' * **Case B.** Supply `x0`, `col0`, `x1`, and `col1`, but *not*
#' `zlim`, `breaks`, `col` or `name`.
#' The `x0`, `col0`, `x1` and `col1` values specify a
#' value-color mapping that is similar to that used
#' for GMT color maps. The method works by using [seq()] to
#' interpolate between the elements of the `x0` vector. The same is done
#' for `x1`. Similarly, [colorRampPalette()] is used to
#' interpolate between the colors in the `col0` vector, and the same is
#' done for `col1`. \if{html}{The figure above explains the (`x0`,
#' `x1`, `col0`, `col1`) method of specifying a color mapping.
#' Note that the each of the items has the same length. The case of
#' `blend=0`, which has color `col0[i]` between `x0[i]` and
#' `x1[i]`, is illustrated below.}
#' \if{html}{\figure{colormap_fig_2.png}}
#'
#' * **Case C.** Supply `name` and possibly also `z`, but *not*
#' `zlim`, `breaks`, `col`, `x0`, `col0`, `x1` or `col1`.
#' The `name` may be the name of a pre-defined color palette
#' (`"gmt_relief"`, `"gmt_ocean"`, `"gmt_globe"` or
#' `"gmt_gebco"`), or it may be the name of a file (or URL pointing to a file)
#' that contains a color map in the GMT format (see \dQuote{References}). If
#' `z` is supplied along with `name`, then `zcol` will be set up in the
#' return value, e.g. for use in colorizing points. Another method
#' for finding colors for data points is to use the `colfunction()`
#' function in the return value.
#'
#' @param z an optional vector or other set of numerical values to be examined.
#' If `z` is given, the return value will contain an item named
#' `zcol` that will be a vector of the same length as `z`, containing
#' a color for each point. If `z` is not given, `zcol` will contain
#' just one item, the color `"black"`.
#'
#' @param zlim optional vector containing two numbers that specify the `z`
#' limits for the color scale. This can only be provided in cases A
#' and B, as defined in \dQuote{Details}. For case A, if `zlim` is not
#' provided, then it is inferred by using [rangeExtended()]
#' on `breaks`, if that is provided, or from `z` otherwise. Also,
#' in case A, it is an error to provide both `zlim` and `breaks`,
#' unless the latter is of length 1, meaning the number of
#' subdivisions to use within the range set by `zlim`.
#' In case B, `zlim` is inferred from using [rangeExtended()] on `c(x0,x1)`.
#' In case C, providing `zlim` yields an error message, because it makes no
#' sense in the context of a named, predefined color scheme.
#'
#' @param zclip logical, with `TRUE` indicating that z values outside the
#' range of `zlim` or `breaks` should be painted with
#' `missingColor` and `FALSE` indicating that these values should be
#' painted with the nearest in-range color.
#'
#' @param breaks an optional indication of break points between color levels
#' (see [image()]). If this is provided, the arguments `name`
#' through `blend` are all ignored (see \dQuote{Details}). If it is
#' provided, then it may either be a vector of break points, or a single number
#' indicating the desired number of break points to be computed with
#' [`pretty`]`(z,breaks)`. In either case of non-missing
#' `breaks`, the resultant break points must number 1 plus the number of
#' colors (see `col`).
#'
#' @param col either a vector of colors or a function taking a numerical value
#' as its single argument and returning a vector of colors. Prior to 2021-02-08,
#' the default for `col` was `oceColorsJet`, but it was switched to
#' `oceColorsViridis` on that date. The value of
#' `col` is ignored if `name` is provided, or if `x0` through
#' `col1` are provided.
#'
#' @param name an optional string naming a built-in colormap (one of
#' `"gmt_relief"`, `"gmt_ocean"`, `"gmt_globe"` or
#' `"gmt_gebco"`) or the name of a file or URL that contains a color map
#' specification in GMT format. If `name` is given, then it is
#' passed to [colormapGMT()], which creates the colormap.
#' Note that the colormap thus created has a fixed
#' relationship between value and color, and `zlim`,
#` `z0`, etc. are ignored when `name` is provided. Indeed, the
#' only other argument that is examined is `z` (which may be used
#' so that `zcol` will be defined in the return value), and warnings
#' are issued if some irrelevant arguments are provided.
#'
#' @param x0,x1,col0,col1 Vectors that specify a color map. They must all be
#' the same length, with `x0` and `x1` being numerical values, and
#' `col0` and `col1` being colors. The colors may be strings (e.g.
#' `"red"`) or colors as defined by [rgb()] or [hsv()].
#'
#' @param blend a number indicating how to blend colors within each band.
#' This is ignored except when `x0` through `col1` are supplied. A
#' value of 0 means to use `col0[i]` through the interval `x0[i]` to
#' `x1[i]`. A value of 1 means to use `col1[i]` in that interval. A
#' value between 0 and 1 means to blend between the two colors according to
#' the stated fraction. Values exceeding 1 are an error at present, but there
#' is a plan to use this to indicate sub-intervals, so a smooth palette can be
#' created from a few colors.
#'
#' @param missingColor color to use for missing values. This cannot be provided
#' if `name` is also provided (case C), because named schemes have pre-defined
#' colors. For other cases, `missingColor` defaults to `"gray"`, if it
#' is not provided as an argument.
#'
#' @param debug a flag that turns on debugging. Set to 1 to get a moderate
#' amount of debugging information, or to 2 to get more.
#'
#' @return a list containing the following (not necessarily in this order)
#'
#' * `zcol`, a vector of colors for `z`, if `z` was
#' provided, otherwise `"black"`
#'
#' * `zlim`, a two-element vector suitable as the argument of the same
#' name supplied to [image()] or [imagep()]
#'
#' * `breaks` and `col`, vectors of breakpoints and colors,
#' suitable as the same-named arguments to [image()] or
#' [imagep()]
#'
#' * `zclip` the provided value of `zclip`.
#'
#' * `x0` and `x1`, numerical vectors of the sides of color
#' intervals, and `col0` and `col1`, vectors of corresponding
#' colors. The meaning is the same as on input. The purpose of returning
#' these four vectors is to permit users to alter color mapping, as in example
#' 3 in \dQuote{Examples}.
#'
#' * `missingColor`, a color that could be used to specify missing
#' values, e.g. as the same-named argument to [imagep()].
#'
#' * `colfunction`, a univariate function that returns a vector
#' of colors, given a vector of `z` values; see Example 6.
#'
#' @author Dan Kelley
#'
#' @examples
#' library(oce)
#' # Example 1. color scheme for points on xy plot
#' x <- seq(0, 1, length.out=40)
#' y <- sin(2 * pi * x)
#' par(mar=c(3, 3, 1, 1))
#' mar <- par('mar') # prevent margin creep by drawPalette()
#' # First, default breaks
#' c <- colormap(y)
#' drawPalette(c$zlim, col=c$col, breaks=c$breaks)
#' plot(x, y, bg=c$zcol, pch=21, cex=1)
#' grid()
#' par(mar=mar)
#' # Second, 100 breaks, yielding a smoother palette
#' c <- colormap(y, breaks=100)
#' drawPalette(c$zlim, col=c$col, breaks=c$breaks)
#' plot(x, y, bg=c$zcol, pch=21, cex=1)
#' grid()
#' par(mar=mar)
#'
#'\dontrun{
#' # Example 2. topographic image with a standard color scheme
#' par(mfrow=c(1,1))
#' data(topoWorld)
#' cm <- colormap(name="gmt_globe")
#' imagep(topoWorld, breaks=cm$breaks, col=cm$col)
#'
#' # Example 3. topographic image with modified colors,
#' # black for depths below 4km.
#' cm <- colormap(name="gmt_globe")
#' deep <- cm$x0 < -4000
#' cm$col0[deep] <- 'black'
#' cm$col1[deep] <- 'black'
#' cm <- colormap(x0=cm$x0, x1=cm$x1, col0=cm$col0, col1=cm$col1)
#' imagep(topoWorld, breaks=cm$breaks, col=cm$col)
#'
#' # Example 4. image of world topography with water colorized
#' # smoothly from violet at 8km depth to blue
#' # at 4km depth, then blending in 0.5km increments
#' # to white at the coast, with tan for land.
#' cm <- colormap(x0=c(-8000, -4000, 0, 100),
#' x1=c(-4000, 0, 100, 5000),
#' col0=c("violet","blue","white","tan"),
#' col1=c("blue","white","tan","yellow"))
#' lon <- topoWorld[['longitude']]
#' lat <- topoWorld[['latitude']]
#' z <- topoWorld[['z']]
#' imagep(lon, lat, z, breaks=cm$breaks, col=cm$col)
#' contour(lon, lat, z, levels=0, add=TRUE)
#'
#' # Example 5. visualize GMT style color map
#' cm <- colormap(name="gmt_globe", debug=4)
#' plot(seq_along(cm$x0), cm$x0, pch=21, bg=cm$col0)
#' grid()
#' points(seq_along(cm$x1), cm$x1, pch=21, bg=cm$col1)
#'
#' # Example 6. colfunction
#' cm <- colormap(c(0, 1))
#' x <- 1:10
#' y <- (x - 5.5)^2
#' z <- seq(0, 1, length.out=length(x))
#' drawPalette(colormap=cm)
#' plot(x, y, pch=21, bg=cm$colfunction(z), cex=3)
#'}
#'
#' @family things related to colors
#'
#' @template colourBlindnessTemplate
colormap <- function(z=NULL, zlim, zclip=FALSE, breaks, col=oceColorsViridis,
name, x0, x1, col0, col1, blend=0, missingColor, debug=getOption("oceDebug"))
{
debug <- min(max(0, debug), 1)
#oceDebug(debug, gsub(" = [^,)]*", "", deparse(expr=match.call())), " {\n", style="bold", sep="", unindent=1)
oceDebug(debug, "colormap(...) {\n", sep="", style="bold", unindent=1)
zKnown <- !is.null(z)
zlimKnown <- !missing(zlim)
breaksKnown <- !missing(breaks)
# nolint start object_usage_linter
colKnown <- !missing(col)
# nolint end object_usage_linter
nameKnown <- !missing(name)
x0Known <- !missing(x0)
x1Known <- !missing(x1)
col0Known <- !missing(col0)
col1Known <- !missing(col1)
missingColorKnown <- !missing(missingColor)
# Sanity checks on args
if (blend < 0 || blend > 1)
stop("blend must be between 0 and 1")
if (zlimKnown) {
if (length(zlim) != 2)
stop("'zlim' must be of length 2")
if (any(!is.finite(zlim)))
stop("'zlim' values must be finite")
if (zlim[2] <= zlim[1])
stop("'zlim' values must be ordered and distinct")
}
if (zlimKnown && breaksKnown && length(breaks) > 1)
stop("cannot specify both zlim and breaks, unless length(breaks)==1")
# Find cases (as a way to clarify code, and link it with the docs).
if (nameKnown) {
case <- "C"
} else if (x0Known || col0Known || x1Known || col1Known) {
case <- "B"
} else if (zKnown || zlimKnown || breaksKnown) {
case <- "A"
} else {
case <- "A"
warning("defaulting to case A, which may be incorrect\n")
}
# Case C: 'name' was given: only 'name' and possibly 'z' are examined.
if (case == "C") {
oceDebug(debug, "Case C: name given\n", style="bold")
for (disallowed in c("zlim", "breaks", "col", "x0", "col0", "x1", "col1", "missingColor")) {
if (get(paste0(disallowed, "Known")))
stop("cannot supply '", disallowed, "' since 'name' was supplied (i.e. in Case C)\n")
}
res <- colormap_colormap(name=name, debug=debug-1)
res$zclip <- zclip
res$zlim <- range(c(res$x0, res$x1)) # ignore argument 'zlim'
res$colfunction <- function(z) res$col0[findInterval(z, res$x0, all.inside=TRUE)]
if (zKnown) {
res$zcol <- res$colfunction(z)
}
oceDebug(debug, "} # colormap() case C\n", style="bold", sep="", unindent=1)
return(res)
} # end of case C
if (case == "B") { # x0 col0 x1 col1
oceDebug(debug, "Case B\n", style="bold")
if (!(x0Known && col0Known && x1Known && col1Known))
stop("'x0', 'col0', 'x1', 'col1' must all be supplied, if any is supplied")
for (disallowed in c("name", "breaks", "col")) {
if (get(paste0(disallowed, "Known"))) {
stop("cannot supply '", disallowed, "' since `x0`, `col0`, `x1` and `col1` were supplied (i.e. in Case B)\n")
}
}
if (length(x0) != length(x1))
stop("lengths of x0 and x1 must agree")
if (length(col0) != length(col1))
stop("lengths of col0 and col1 must agree")
if (length(x0) != length(col0))
stop("lengths of x0 and col0 must agree")
if (!identical(x0, sort(x0)))
stop("'x0' must be ordered from small to large")
if (!identical(x1, sort(x1)))
stop("'x1' must be ordered from small to large")
breaks <- c(x0, tail(x1, 1))
# blend colors
col <- col2rgb(col0) # will overwrite
oceDebug(debug, "blend=", blend, "\n", sep="")
for (i in seq_along(col0))
col[, i] <- colorRamp(c(col0[i], col1[i]))(blend)[1, ]
col <- rgb(col[1, ], col[2, ], col[3, ], maxColorValue=255)
if (!missingColorKnown)
missingColor <- "gray"
if (zKnown) {
# BOOKMARK1 -- this code needs to be in synch with BOOKMARK2
i <- findInterval(z, breaks)
missing <- i == 0
i[missing] <- 1 # just pick something; replaced later
zcol <- col[i]
zcol[missing] <- missingColor
if (zclip) {
zcol[missing] <- missingColor
} else {
if (zKnown)
zcol[is.na(z)] <- missingColor
zcol[z <= min(breaks)] <- col[1]
zcol[z >= max(breaks)] <- tail(col, 1)
}
} else {
zcol <- "black"
}
res <- list(x0=x0, x1=x1, col0=col0, col1=col1, missingColor=missingColor,
zclip=zclip, zlim=if (zlimKnown) zlim else rangeExtended(c(x0, x1)),
breaks=breaks, col=col, zcol=zcol)
class(res) <- c("list", "colormap")
oceDebug(debug, "} # colormap() case B\n", style="bold", sep="", unindent=1)
return(res)
} # end of case B
oceDebug(debug, "case 3: name not given, x0 (and related) not given\n")
if (!zlimKnown) {
if (breaksKnown) {
oceDebug(debug, "zlimKnown=", zlimKnown, ", so inferring zlim from breaks\n", sep="")
zlim <- if (length(breaks) > 1) range(breaks) else NULL
zlimKnown <- TRUE
} else if (zKnown) {
oceDebug(debug, "zlimKnown=", zlimKnown, ", so inferring zlim from z\n", sep="")
if (!any(is.finite(z)))
stop("cannot infer zlim, since z has no finite values, and breaks was not given")
zlim <- rangeExtended(z[is.finite(z)])
zlimKnown <- TRUE
} else {
stop("cannot infer zlim; please specify zlim, breaks, name, or z")
}
}
oceDebug(debug, "zlim=", if (is.null(zlim)) "NULL" else zlim, "\n")
oceDebug(debug, "zclip=", zclip, "\n")
blend <- max(blend, 0L)
n <- if (blend > 1L) as.integer(round(blend)) else 1L
oceDebug(debug, "blend=", blend, "; n=", n, "\n", sep="")
# Possibly determine breaks, if not given but if can be inferred from z or zlim
if (!breaksKnown) {
if (zlimKnown) {
oceDebug(debug, "case 3.1 breaks not given, but inferred from zlim\n")
breaks <- seq(min(zlim, na.rm=TRUE), max(zlim, na.rm=TRUE), length.out=255)
oceDebug(debug, "created", length(breaks), "breaks, ranging from", breaks[1], "to", tail(breaks, 1), "\n")
breaksKnown <- TRUE # this makes next block execute also
} else if (zKnown && any(is.finite(z))) {
oceDebug(debug, "case 3.2 breaks not given, but inferred from z\n")
breaks <- seq(min(z, na.rm=TRUE), max(z, na.rm=TRUE), length.out=255)
oceDebug(debug, "created", length(breaks), "breaks, ranging from", breaks[1], "to", tail(breaks, 1), "\n")
breaksKnown <- TRUE
}
}
if (breaksKnown) {
oceDebug(debug, "case 4 breaks given, or inferred from either z or zlim\n")
if (zKnown) {
oceDebug(debug, "case 4.1 construct colormap using z\n")
if (length(breaks) < 2) {
breaks <- seq(min(z, na.rm=TRUE), max(z, na.rm=TRUE), length.out=breaks)
oceDebug(debug, "constructing breaks from z as ", paste(breaks, collapse=" "), "\n")
}
if (missing(missingColor)) {
res <- colormap_colorize(zlim=zlim, zclip=zclip, z=z, breaks=breaks, col=col,
debug=debug-1)
} else {
res <- colormap_colorize(zlim=zlim, zclip=zclip, z=z, breaks=breaks, col=col,
missingColor=missingColor, debug=debug-1)
}
} else {
oceDebug(debug, "case 4.2 construct colormap using zlim\n")
oceDebug(debug, "length(breaks)=", length(breaks), "\n", sep="")
if (length(breaks) < 2) {
breaks <- seq(zlim[1], zlim[2], length.out=breaks)
oceDebug(debug, "constructing breaks from zlim as ", paste(breaks, collapse=" "), "\n")
}
if (missing(missingColor)) {
res <- colormap_colorize(zlim=zlim, zclip=zclip, breaks=breaks, col=col, debug=debug-1)
} else {
res <- colormap_colorize(zlim=zlim, zclip=zclip, breaks=breaks, col=col, missingColor=missingColor, debug=debug-1)
}
res$zcol <- "black"
}
res$x0 <- res$breaks[-1]
res$x1 <- res$breaks[-1]
res$col0 <- res$col
res$col1 <- res$col
}
res$missingColor <- if (missingColorKnown) missingColor else "gray"
res$zclip <- zclip
res$colfunction <- function(z) res$col0[findInterval(z, res$x0)]
class(res) <- c("list", "colormap")
oceDebug(debug, "} # colormap() case A\n", style="bold", sep="", unindent=1)
res
}
# keeping this (which was called 'colormap' until 2014-05-07), but not in NAMESPACE.
colormap_colormap <- function(name, x0, x1, col0, col1, n=1, zclip=FALSE, debug=getOption("oceDebug"))
{
nameKnown <- !missing(name)
oceDebug(debug, "colormap_colormap(name=",
if (nameKnown) paste0("\"", name, "\"") else "(MISSING)",
", ...) {\n", sep="", unindent=1)
if (nameKnown) {
oceDebug(debug, "name was specified, so using colormapGMT() to compute colormap\n")
res <- colormapGMT(name, debug=debug-1)
} else {
oceDebug(debug, "name was not specified, so using x0, x1, etc., to compute colormap\n")
if (missing(x0) || missing(x1) || missing(col0) || missing(col1))
stop('give either "name" or all of: "x0", "x1", "col0" and "col1"')
xlen <- length(x0)
if (length(x1) != xlen)
stop('lengths of "x0" and "x1" must agree')
if (length(col0) != xlen)
stop('lengths of "x0" and "col0" must agree')
if (length(col1) != xlen)
stop('lengths of "x0" and "col1" must agree')
x0r <- x1r <- col0r <- col1r <- NULL
if (length(n) != xlen - 1)
n <- rep(n[1], length.out=xlen)
oceDebug(debug, "x0:", x0, "\n")
oceDebug(debug, "x1:", x1, "\n")
oceDebug(debug, "col0:", col0, "\n")
oceDebug(debug, "col1:", col1, "\n")
#x0A <- c(x0, tail(x1, 1))
for (i in 2:xlen) {
dx0 <- (x0[i] - x0[i-1]) / n[i-1]
x0r <- c(x0r, seq(x0[i-1], by=dx0, length.out=n[i-1]))
dx1 <- (x1[i] - x1[i-1]) / n[i-1]
x1r <- c(x1r, seq(x1[i-1], by=dx1, length.out=n[i-1]))
col0r <- c(col0r, colorRampPalette(col0[seq.int(i-1, i)])(n[i-1]))
col1r <- c(col1r, colorRampPalette(col1[seq.int(i-1, i)])(n[i-1]))
oceDebug(debug, "i=", i, "\n")
oceDebug(debug, " x0[i-1]", x0[i-1], "x0[i]", x0[i], "\n")
oceDebug(debug, " concat x0:", seq(x0[i-1], by=dx0, length.out=1+n[i-1]), "\n")
oceDebug(debug, " col0[i-1]:", col0[i-1], "col0[i]:", col0[i], "\n")
oceDebug(debug, " col1[i-1]:", col1[i-1], "col1[i]:", col1[i], "\n")
}
# next is wrong -- should not just tack on one value unless n=1
x0r <- c(x0r, tail(x0, 1))
x1r <- c(x1r, tail(x1, 1))
col0r <- c(col0r, tail(col0, 1))
col1r <- c(col1r, tail(col1, 1))
res <- list(x0=x0r, x1=x1r, col0=col0r, col1=col1r)
}
res$zclip <- zclip
class(res) <- c("list", "colormap")
oceDebug(debug, "} # colormap_colormap()\n", sep="", unindent=1)
res
}
# internal function for palettes
palette2breakscolor <- function(name, breaksPerLevel=1, topoRegion=c("water", "land", "both"))
{
knownPalettes <- c("GMT_relief", "GMT_ocean", "globe")
palette <- pmatch(name, knownPalettes)
if (is.na(palette))
stop("unknown palette name \"", name, "\"")
name <- knownPalettes[palette]
if (name == "GMT_relief") {
# GMT based on
# GMT_relief.cpt,v 1.1 2001/09/23 23:11:20 pwessel Exp $
d <- list(l=1000*c(-8, -7, -6, -5, -4, -3, -2, -1, 0, 0.5, 1, 2, 3, 4, 5, 6, 7),
lr=c(0, 0, 0, 0, 0, 86, 172, 211, 70, 120, 146, 198, 250, 250, 252, 252, 253),
lg=c(0, 5, 10, 80, 150, 197, 245, 250, 120, 100, 126, 178, 230, 234, 238, 243, 249),
lb=c(0, 25, 50, 125, 200, 184, 168, 211, 50, 50, 60, 80, 100, 126, 152, 177, 216),
u=1000*c(-7, -6, -5, -4, -3, -2, -1, 0, 0.5, 1, 2, 3, 4, 5, 6, 7, 8),
ur=c(0, 0, 0, 0, 86, 172, 211, 250, 120, 146, 198, 250, 250, 252, 252, 253, 255),
ug=c(5, 10, 80, 150, 197, 245, 250, 255, 100, 126, 178, 230, 234, 238, 243, 249, 255),
ub=c(25, 50, 125, 200, 184, 168, 211, 255, 50, 60, 80, 100, 126, 152, 177, 216, 255),
f="#FFFFFF",
b="#000000",
n="#FFFFFF")
} else if (name == "GMT_ocean") {
d <- list(l=1000*c(-8, -7, -6, -5, -4, -3, -2, -1),
lr=c(0, 0, 0, 0, 0, 86, 172, 211),
lg=c(0, 5, 10, 80, 150, 197, 245, 250),
lb=c(0, 25, 50, 125, 200, 184, 168, 211),
u=1000*c(-7, -6, -5, -4, -3, -2, -1, 0),
ur=c(0, 0, 0, 0, 0, 86, 172, 211, 250),
ug=c(5, 10, 80, 150, 197, 245, 250, 255),
ub=c(25, 50, 125, 200, 184, 168, 211, 255),
f="#FFFFFF",
b="#000000",
n="#FFFFFF")
} else if (name == "globe") {
# nolint start (long lines)
d <- list(
l=1000*c(-10, -9.5, -9, -8.5, -8, -7.5, -7, -6.5, -6, -5.5, -5, -4.5, -4, -3.5, -3, -2.5, -2, -1.5, -1, -0.5, -0.2, 0, 0.1, 0.2, 0.5, 1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, 9, 9.5),
lr=c(153, 153, 153, 136, 119, 102, 85, 68, 51, 34, 17, 0, 27, 54, 81, 108, 134, 161, 188, 215, 241, 51, 51, 187, 255, 243, 230, 217, 168, 164, 162, 159, 156, 153, 162, 178, 183, 194, 204, 229, 242, 255, 255),
lg=c(0, 0, 0, 17, 34, 51, 68, 85, 102, 119, 136, 153, 164, 175, 186, 197, 208, 219, 230, 241, 252, 102, 204, 228, 220, 202, 184, 166, 154, 144, 134, 123, 113, 102, 89, 118, 147, 176, 204, 229, 242, 255, 255),
lb=c(255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 0, 102, 146, 185, 137, 88, 39, 31, 25, 19, 13, 7, 0, 89, 118, 147, 176, 204, 229, 242, 255, 255),
u=1000*c(-9.5, -9, -8.5, -8, -7.5, -7, -6.5, -6, -5.5, -5, -4.5, -4, -3.5, -3, -2.5, -2, -1.5, -1, -0.5, -0.2, 0, 0.1, 0.2, 0.5, 1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7, 7.5, 8, 8.5, 9, 9.5, 10),
ur=c(153, 153, 153, 136, 119, 102, 85, 68, 51, 34, 17, 0, 27, 54, 81, 108, 134, 161, 188, 215, 241, 51, 187, 255, 243, 230, 217, 168, 164, 162, 159, 156, 153, 162, 178, 183, 194, 204, 229, 242, 255, 255, 255),
ug=c(0, 0, 0, 17, 34, 51, 68, 85, 102, 119, 136, 153, 164, 175, 186, 197, 208, 219, 230, 241, 252, 204, 228, 220, 202, 184, 166, 154, 144, 134, 123, 113, 102, 89, 118, 147, 176, 204, 229, 242, 255, 255, 255),
ub=c(255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, 102, 146, 185, 137, 88, 39, 31, 25, 19, 13, 7, 0, 89, 118, 147, 176, 204, 229, 242, 255, 255, 255),
f="#FFFFFF",
b="#000000",
n="#808080")
# nolint end (long lines)
} else {
stop("'", palette, "' is not a recognized value for 'palette'")
}
nlevel <- length(d$l)
breaks <- NULL
col <- NULL
for (l in 1:nlevel) {
lowerColor <- rgb(d$lr[l]/255, d$lg[l]/255, d$lb[l]/255)
upperColor <- rgb(d$ur[l]/255, d$ug[l]/255, d$ub[l]/255)
breaks <- c(breaks, seq(d$l[l], d$u[l], length.out=1+breaksPerLevel))
col <- c(col, colorRampPalette(c(lowerColor, upperColor))(1+breaksPerLevel))
}
if (palette %in% c("GMT_relief")) {
if (topoRegion == "water") {
wet <- breaks <= 0
breaks <- breaks[wet]
col <- col[wet]
} else if (topoRegion == "land") {
dry <- breaks >= 0
breaks <- breaks[dry]
col <- col[dry]
}
}
# remove last color since must have 1 more break than color
col <- head(col, -1)
list(breaks=breaks, col=col, f=d$f, b=d$b, n=d$n)
}
Try the oce package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.