https://github.com/cran/spatstat
Tip revision: 9546dc7d46268c9a53dbf4c703c12e5b4fc8e7c4 authored by Adrian Baddeley on 23 August 2012, 12:07:28 UTC
version 1.28-2
version 1.28-2
Tip revision: 9546dc7
colourtables.R
#
# colourtables.R
#
# support for colour maps and other lookup tables
#
# $Revision: 1.16 $ $Date: 2011/05/18 01:34:03 $
#
colourmap <- function(col, ..., range=NULL, breaks=NULL, inputs=NULL) {
# validate colour data
h <- col2hex(col)
f <- lut(col, ..., range=range, breaks=breaks, inputs=inputs)
class(f) <- c("colourmap", class(f))
f
}
lut <- function(outputs, ..., range=NULL, breaks=NULL, inputs=NULL) {
n <- length(outputs)
given <- c(!is.null(range), !is.null(breaks), !is.null(inputs))
names(given) <- c("range", "breaks", "inputs")
ngiven <- sum(given)
if(ngiven == 0)
stop(paste("One of the arguments",
sQuote("range"), ",", sQuote("breaks"), "or", sQuote("inputs"),
"should be given"))
if(ngiven > 1) {
offending <- names(breaks)[given]
stop(paste("The arguments",
commasep(sQuote(offending)),
"are incompatible"))
}
if(!is.null(inputs)) {
# discrete set of input values mapped to output values
stopifnot(length(inputs) == length(outputs))
stuff <- list(n=n, discrete=TRUE, inputs=inputs, outputs=outputs)
f <- function(x, what="value") {
m <- match(x, stuff$inputs)
if(what == "index")
return(m)
cout <- stuff$outputs[m]
return(cout)
}
} else {
# interval of real line mapped to colours
if(is.null(breaks)) {
breaks <- seq(from=range[1], to=range[2], length.out=length(outputs)+1)
} else {
stopifnot(is.numeric(breaks) && length(breaks) >= 2)
stopifnot(length(breaks) == length(outputs) + 1)
if(!all(diff(breaks) > 0))
stop("breaks must be increasing")
}
stuff <- list(n=n, discrete=FALSE, breaks=breaks, outputs=outputs)
f <- function(x, what="value") {
stopifnot(is.numeric(x))
x <- as.vector(x)
z <- findInterval(x, stuff$breaks,
rightmost.closed=TRUE)
if(what == "index")
return(z)
cout <- stuff$outputs[z]
return(cout)
}
}
attr(f, "stuff") <- stuff
class(f) <- c("lut", class(f))
f
}
print.lut <- function(x, ...) {
stuff <- attr(x, "stuff")
n <- stuff$n
if(inherits(x, "colourmap")) {
tablename <- "Colour map"
outputname <- "colour"
} else {
tablename <- "Lookup table"
outputname <- "output"
}
if(stuff$discrete) {
cat(paste(tablename, "for discrete set of input values\n"))
out <- data.frame(input=stuff$inputs, output=stuff$outputs)
} else {
b <- stuff$breaks
cat(paste(tablename, "for the range", prange(b[c(1,n+1)]), "\n"))
leftend <- rep("[", n)
rightend <- c(rep(")", n-1), "]")
inames <- paste(leftend, b[-(n+1)], ", ", b[-1], rightend, sep="")
out <- data.frame(interval=inames, output=stuff$outputs)
}
colnames(out)[2] <- outputname
print(out)
invisible(NULL)
}
print.colourmap <- function(x, ...) {
NextMethod("print")
}
summary.lut <- function(object, ...) {
s <- attr(object, "stuff")
if(inherits(object, "colourmap")) {
s$tablename <- "Colour map"
s$outputname <- "colour"
} else {
s$tablename <- "Lookup table"
s$outputname <- "output"
}
class(s) <- "summary.lut"
return(s)
}
print.summary.lut <- function(x, ...) {
n <- x$n
if(x$discrete) {
cat(paste(x$tablename, "for discrete set of input values\n"))
out <- data.frame(input=x$inputs, output=x$outputs)
} else {
b <- x$breaks
cat(paste(x$tablename, "for the range", prange(b[c(1,n+1)]), "\n"))
leftend <- rep("[", n)
rightend <- c(rep(")", n-1), "]")
inames <- paste(leftend, b[-(n+1)], ", ", b[-1], rightend, sep="")
out <- data.frame(interval=inames, output=x$outputs)
}
colnames(out)[2] <- x$outputname
print(out)
}
plot.colourmap <- function(x, ..., main,
xlim=NULL, ylim=NULL, vertical=FALSE, axis=TRUE) {
if(missing(main))
main <- short.deparse(substitute(x))
stuff <- attr(x, "stuff")
col <- stuff$outputs
n <- stuff$n
discrete <- stuff$discrete
# determine pixel entries 'v' and colour map breakpoints 'bks'
# to be passed to 'image.default'
if(!discrete) {
bks <- stuff$breaks
rr <- range(bks)
v <- seq(from=rr[1], to=rr[2], length.out=max(n+1, 1024))
} else {
v <- (1:n) - 0.5
bks <- 0:n
rr <- c(0,n)
}
# determine position of ribbon
if(is.null(xlim) && is.null(ylim)) {
u <- diff(rr)/10
if(!vertical) {
xlim <- rr
ylim <- c(0,u)
} else {
xlim <- c(0,u)
ylim <- rr
}
} else if(is.null(ylim)) {
if(!vertical)
ylim <- c(0, diff(xlim)/10)
else
ylim <- c(0, 10 * diff(xlim))
} else if(is.null(xlim)) {
if(!vertical)
xlim <- c(0, 10 * diff(ylim))
else
xlim <- c(0, diff(ylim)/10)
}
# plot ribbon image
linmap <- function(x, from, to) {
to[1] + diff(to) * (x - from[1])/diff(from)
}
if(!vertical) {
x <- linmap(v, rr, xlim)
y <- ylim
z <- matrix(v, ncol=1)
do.call("image.default",
resolve.defaults(list(x, y, z),
list(...),
list(main=main, xlim=xlim, ylim=ylim, asp=1.0,
ylab="", xlab="", axes=FALSE,
breaks=bks, col=col)))
if(axis) {
if(discrete) {
la <- paste(stuff$inputs)
at <- linmap(v, rr, xlim)
} else {
la <- pretty(rr)
at <- linmap(la, rr, xlim)
}
axis(1, pos=ylim[1], at=at, labels=la)
}
} else {
y <- linmap(v, rr, ylim)
z <- matrix(v, nrow=1)
x <- xlim
do.call("image.default",
resolve.defaults(list(x, y, z),
list(...),
list(main=main, ylim=ylim, xlim=xlim, asp=1.0,
ylab="", xlab="", axes=FALSE,
breaks=bks, col=col)))
if(axis) {
if(discrete) {
la <- paste(stuff$inputs)
at <- linmap(v, rr, ylim)
} else {
la <- pretty(rr)
at <- linmap(la, rr, ylim)
}
axis(4, pos=xlim[2], at=at, labels=la)
}
}
invisible(NULL)
}