https://github.com/cran/plotKML
Tip revision: ca791724bfe0f7655d8d7debc093a1a40b6ac705 authored by Tomislav Hengl on 15 January 2013, 00:00:00 UTC
version 0.4-2
version 0.4-2
Tip revision: ca79172
aesthetics.R
# Purpose : List of available aesthetics is given .all_kml_aesthetics along with their default values
# Maintainer : Pierre Roudier (pierre.roudier@landcare.nz);
# Contributions : Tomislav Hengl (tom.hengl@wur.nl); Dylan Beaudette (debeaudette@ucdavis.edu);
# Dev Status : Pre-Alpha
# Note : Functionality for constant transparency under development;
.all_kml_aesthetics <- list(
colour = "black",
fill = "white",
shape = paste(get("home_url", envir = plotKML.opts), get("icon", envir = plotKML.opts), sep=""),
whitening = "",
alpha = 1,
size = get("LabelScale", envir = plotKML.opts),
width = 1,
labels = "",
altitude = 0,
altitudeMode = "",
balloon = FALSE
)
# Parsing a call
#
.parse_call_for_aes <- function(call) {
called_options <- names(call)
ind_aes <- charmatch(called_options, names(.all_kml_aesthetics))
names(.all_kml_aesthetics)[ind_aes[!is.na(ind_aes)]]
}
# Applying aesthetics
#
kml_aes <- function(obj, ...) {
# Getting parent call
parent_call <- substitute(list(...))
parent_call <- as.list(parent_call)[-1]
# Parse the current call
called_aes <- .parse_call_for_aes(parent_call)
aes <- list()
# Names
if ("labels" %in% called_aes) {
# If labels defined using a column of data
if (is.name(parent_call[['labels']])){
aes[['labels']] <- as.character(obj[[as.character(parent_call[['labels']])]])
}
# if labels given as a vector
else {
labels <- eval(parent_call[['labels']])
if (length(labels) == length(obj))
aes[['labels']] <- as.character(labels)
else
aes[['labels']] <- rep(as.character(labels), length.out = length(obj))
}
}
else {
if ("data" %in% slotNames(obj)) {
# If only one data column is represented, we use its values as labels
if (length(called_aes) == 1) {
# If its the name of a column
if (is.name(parent_call[[called_aes]])) {
# If the column is numeric
if (is.numeric(obj[[as.character(parent_call[[called_aes]])]]))
aes[['labels']] <- as.character(round(obj[[as.character(parent_call[[called_aes]])]], digits = 3))
# Otherwise
else
aes[['labels']] <- as.character(obj[[as.character(parent_call[[called_aes]])]])
}
# If its a call we have to evaluate it first
else if (is.call(parent_call[[called_aes]]))
aes[['labels']] <- as.character(format(eval(parent_call[[called_aes]], obj@data), digits = 3))
# default behaviour is just numbering using the N first integers
else
aes[['labels']] <- as.character(1:length(obj))
}
else
aes[['labels']] <- rownames(obj@data)
}
else
# default behaviour is just numbering using the N first integers
aes[['labels']] <- as.character(1:length(obj))
}
# Colour
if ("colour" %in% called_aes) {
# If a column name as been used
if (is.name(parent_call[['colour']]) | is.call(parent_call[['colour']]) & "data" %in% slotNames(obj)) {
# Trying to get the colour ramp
if ("colour_scale" %in% names(parent_call)){
if("z.lim" %in% names(parent_call)){
aes[['colour']] <- kml_colour(obj, colour = parent_call[['colour']], colour_scale = parent_call[['colour_scale']], z.lim = eval(parent_call[['z.lim']]))
} else {
aes[['colour']] <- kml_colour(obj, colour = parent_call[['colour']], colour_scale = parent_call[['colour_scale']])
}
}
# Otherwise use the default colour ramp
else {
if("z.lim" %in% names(parent_call)){
aes[['colour']] <- kml_colour(obj, colour = parent_call[['colour']], z.lim = eval(parent_call[['z.lim']]))
} else {
aes[['colour']] <- kml_colour(obj, colour = parent_call[['colour']])
}
}
}
# Otherwise it is interpreted as a colour to use
else {
aes[['colour']] <- rep(col2kml(parent_call[['colour']]), length.out = length(obj))
}
}
# using the default value
else {
aes[['colour']] <- rep(col2kml(.all_kml_aesthetics[["colour"]]), length.out = length(obj))
}
# Alpha
if ("alpha" %in% called_aes) {
aes[['colour']] <- kml_alpha(obj, alpha = eval(parent_call[['alpha']], obj@data), colours = aes[['colour']])
}
# else {
# aes[['alpha']] <- rep(.all_kml_aesthetics[["alpha"]], length.out = length(obj))
# }
# Whitening
# if ("whitening" %in% called_aes) {
# aes[['colour']] <- kml_whitening(obj, whitening, aes[['colour']], ...)
# }
# Shape
if ("shape" %in% called_aes) {
aes[["shape"]] <- kml_shape(obj, ...)
}
else {
aes[["shape"]] <- rep(.all_kml_aesthetics[["shape"]], length.out = length(obj))
}
# Size
if ("size" %in% called_aes) {
# If a column name has been used
if (is.name(parent_call[['size']])){
aes[['size']] <- kml_size(obj, size = as.character(parent_call[['size']]))
}
# Otherwise it is interpreted as a vector
else {
aes[['size']] <- rep(parent_call[['size']], length.out = length(obj))
}
}
else {
aes[['size']] <- rep(.all_kml_aesthetics[["size"]], length.out = length(obj))
}
# Width
if ("width" %in% called_aes) {
# If a column name has been used
if(is.call(parent_call[['width']])){
aes[['width']] <- eval(parent_call[['width']])
} else {
if (is.name(parent_call[['width']])){
aes[['width']] <- kml_width(obj, width = as.character(parent_call[['width']]))
}
# Otherwise it is interpreted as a vector
else {
aes[['width']] <- rep(parent_call[['width']], length.out = length(obj))
}
}}
else {
aes[['width']] <- rep(.all_kml_aesthetics[["width"]], length.out = length(obj))
}
# Altitude
if ("altitude" %in% called_aes) {
aes[['altitude']] <- kml_altitude(obj, altitude = eval(parent_call[['altitude']], obj@data))
}
else {
aes[['altitude']] <- kml_altitude(obj)
}
# AltitudeMode
if ("altitudeMode" %in% called_aes) {
aes[["altitudeMode"]] <- parent_call[['altitudeMode']]
}
else {
aes[["altitudeMode"]] <- kml_altitude_mode(aes[['altitude']])
}
# Balloon (pop ups)
if ("balloon" %in% called_aes) {
aes[['balloon']] <- eval(parent_call[['balloon']])
}
else {
aes[['balloon']] <- .all_kml_aesthetics[["balloon"]]
}
aes
}
.getColourScale <- function(data, z.lim, colour_scale = NULL) {
## default colour palettes
.colour_scale_numeric = get("colour_scale_numeric", envir = plotKML.opts)
.colour_scale_factor = get("colour_scale_factor", envir = plotKML.opts)
if (is.null(colour_scale)) {
# If data is numeric
if (is.numeric(data)) {
colour_scale <- .colour_scale_numeric
}
# If data is a factor
else {
colour_scale <- .colour_scale_factor
}
}
else {
colour_scale <- eval(colour_scale)
}
# creates pal function
pal <- colorRamp(colour_scale, space = "rgb", interpolate = "linear")
if (is.numeric(data)) {
if(missing(z.lim)) { z.lim = range(data, na.rm = TRUE, finite = TRUE) }
data <- scales::rescale(data, from=z.lim)
data <- ifelse(data<0, 0, ifelse(data>1, 1, data))
cols <- rep("#FFFFFF", length(data))
cols[!(is.na(data)|is.nan(data))] <- rgb(pal(data[!(is.na(data)|is.nan(data))]) / 255)
}
# factor variable:
else {
# if it is not numeric, it must be a factor:
data <- as.factor(data)
values <- 1:length(levels(data))
cols <- rep("#FFFFFF", length(values))
values <- scales::rescale(values) # putting values between 0 and 1
cols[!(is.na(values)|is.nan(values))] <- rgb(pal(values[!(is.na(values)|is.nan(values))]) / 255)
# In case of a factor variable, reclassify each level by its corresponding colour:
levels(data) <- cols
cols <- as.character(data)
}
cols
}
# Colour (points, polygons, lines, raster)
##----------------
kml_colour <- function(obj, colour, colour_scale = NULL, ...){
# Getting the vector of values to scale
x <- eval(colour, envir = obj@data)
# Retrieving colour scale
cols <- .getColourScale(data = x, colour_scale = colour_scale, ...)
cols <- col2kml(cols)
return(cols)
}
## Shape (points)
##----------------
kml_shape <- function(obj, shape, ...){
# Simple implementation if a URL is given
rep(shape, length.out = length(obj))
}
# modification of the colours using that alpha value
.includeAlphaInColourRamp <- function(colours, alpha, RGBA = FALSE) {
# colours is a vector of characters describing the colour ramp values
# alpha is a value between 0 and 255
# RGBA is set to flase if for kml colour, true for RGBA colours
# Conversion to hex mode
alpha <- sprintf("%X", alpha)
colours <- str_sub(colours, 2, str_length(colours))
if (RGBA)
b <- cbind("#", colours, alpha)
else
b <- cbind('#', alpha, aaply(colours, 1, function(x) str_sub(x, 3, 9)))
res <- apply(b, 1, function(x) paste(x, collapse = ""))
if (RGBA)
res <- toupper(res)
else
res <- tolower(res)
res
}
# Opacity (points, polygons, lines, raster)
#
# This function modifies the vector of KML colours
kml_alpha <- function(obj, alpha, colours, RGBA = FALSE, ...){
# Alpha is constant or continuous
if (is.numeric(alpha)) {
# rescaling data if continuous case
if (length(alpha) > 1)
alpha <- scales::rescale(alpha)
alpha <- round(255*alpha, digits = 0)
cols <- .includeAlphaInColourRamp(colours, alpha, RGBA)
# # Constant transparency
# if (length(alpha) == 1) {
# # modification of the KML colours using that alpha value
# if (RGBA) {
# # Conversion to hex mode
# alpha <- sprintf("%X", alpha)
# # Adding hex A (alpha) to a RGB hex string
# cols <- aaply(colours, 1, function(x) paste(x, alpha, sep = ""))
# }
# else {
# # Conversion to hex mode
# alpha <- sprintf("%x", alpha)
# cols <- aaply(colours, 1, function(x) paste("#", alpha, str_sub(x, 4, 9), sep = ""))
# }
# }
# # transparency as an aesthetic
# else {
# }
}
# Categorical data
else {
if (is.numeric(obj)) {
limits <- range(obj, na.rm = TRUE, finite = TRUE)
brks <- seq(limits[1], limits[2], length.out = length(colours))
grps <- cut(obj, breaks = brks, include.lowest = TRUE)
}
else
stop("Transparency is only available for numeric data.")
}
cols
}
# Whitening of a given coloured layer (update of the colour vector)
# kml_whitening <- function(obj, whitening, col.vect){
#
# }
# Size (points)
kml_size <- function(obj, size, size.min = get("size_range", envir = plotKML.opts)[1], size.max = get("size_range", envir = plotKML.opts)[2], size.default = 1){
if (!is.na(size) & "data" %in% slotNames(obj)) {
## If data is numeric
if (is.numeric(obj[[size]])) {
max.value <- max(obj[[size]], na.rm = TRUE)
size.values <- size.min + scales::rescale(obj[[size]], from = range(obj[[size]], na.rm = TRUE)) * size.max
## fix the missing values:
size.values[is.na(size.values)] <- size.default
}
# Otherwise: factor, character, logical, ...
else {
if (!is.factor(obj[[size]])){
obj[[size]] <- factor(obj[[size]])
}
## compute number of levels
nl <- nlevels(obj[[size]])
## compute the different size values
sizes.levels <- seq(size.min, size.max, length.out = nl)
## assign them to different classes:
sizes.values <- cut(as.integer(obj[[size]]), breaks = seq(1, nl + 1, by=1), labels = sizes.levels, include.lowest = TRUE)
size.values <- as.numeric(as.character(sizes.values))
## fix the missing values:
size.values[is.na(size.values)] <- size.default
}
} else {
## If no size aesthetic is asked, or if no data slot
size.values <- rep(size.default, length.out = length(obj))
}
return(size.values)
}
# Width (lines)
kml_width <- function(obj, width, width.min = 1, width.max = 6, width.default = 1){
if (!is.na(width) & "data" %in% slotNames(obj)) {
# If data is numeric
if (is.numeric(obj[[width]])) {
max.value <- max(obj[[width]], na.rm = TRUE)
width.values <- round(width.min + scales::rescale(obj[[width]]) * width.max, 0)
}
# Otherwise: factor, character, logical, ...
else {
if (!is.factor(obj[[width]]))
obj[[width]] <- factor(obj[[width]])
# compute number of levels
nl <- nlevels(obj[[width]])
# compute the different size values
width.levels <- seq(width.min, width.max, length.out = nl)
# affect them to the factor
width.values <- cut(obj[[width]], breaks = quantile(obj[[width]], probs=seq(0, 1, length.out = nl + 1)), labels = width.levels, include.lowest = TRUE)
width.values <- as.numeric(as.character(width.values))
}
}
# If no size aesthetic is asked, or if no data slot
else
width.values <- rep(width.default, length.out = length(obj))
width.values
}
# end of script;