An error occurred while loading the file. Please try again.
-
Georges Kunstler authoredd9d8bfd0
##' @exportto.pdf <- function(expr, filename, ..., verbose=TRUE) { if(!file.exists(dirname(filename))) dir.create(dirname(filename), recursive=TRUE) if ( verbose ) cat(sprintf("Creating %s\n", filename)) pdf(filename, ...) on.exit(dev.off()) eval.parent(substitute(expr))}##' @exportto.dev <- function(expr, dev, filename, ..., verbose=TRUE){ if(!file.exists(dirname(filename))) dir.create(dirname(filename), recursive=TRUE) if ( verbose ) cat(sprintf("Creating %s\n", filename)) dev(filename, ...) on.exit(dev.off()) eval.parent(substitute(expr))}##' @exportna.clean <-function(x){x[!is.na(x)]}#returns up to 80 unique, nice colors,#generated using http://tools.medialab.sciences-po.fr/iwanthue/# Starts repeating after 80##' @exportniceColors<-function(n=80){ cols<-rep(c("#75954F","#D455E9","#E34423","#4CAAE1","#451431","#5DE737", "#DC9B94","#DC3788","#E0A732","#67D4C1","#5F75E2","#1A3125", "#65E689","#A8313C","#8D6F96","#5F3819","#D8CFE4","#BDE640", "#DAD799","#D981DD","#61AD34","#B8784B","#892870","#445662", "#493670","#3CA374","#E56C7F","#5F978F","#BAE684","#DB732A", "#7148A8","#867927","#918C68","#98A730","#DDA5D2","#456C9C", "#2B5024","#E4D742","#D3CAB6","#946661","#9B66E3","#AA3BA2", "#A98FE1","#9AD3E8","#5F8FE0","#DF3565","#D5AC81","#6AE4AE", "#652326","#575640","#2D6659","#26294A","#DA66AB","#E24849", "#4A58A3","#9F3A59","#71E764","#CF7A99","#3B7A24","#AA9FA9", "#DD39C0","#604458","#C7C568","#98A6DA","#DDAB5F","#96341B", "#AED9A8","#55DBE7","#57B15C","#B9E0D5","#638294","#D16F5E", "#504E1A","#342724","#64916A","#975EA8","#9D641E","#59A2BB", "#7A3660","#64C32A"), ceiling(n/80)) cols[1:n]}##' @exportmake.transparent <- function(col, opacity=0.5) { tmp <- col2rgb(col)/255 rgb(tmp[1,], tmp[2,], tmp[3,], alpha=opacity)}## Position label at a fractional x/y position on a plot##' @exportlabel <- function(px, py, lab, ..., adj=c(0, 1)) { usr <- par("usr") text(usr[1] + px*(usr[2] - usr[1]), usr[3] + py*(usr[4] - usr[3]), lab, adj=adj, ...)}##' @exportis.wholenumber <- function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol##' @export7172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140
axis.log10 <- function(side=1, horiz=FALSE, labels=TRUE, baseAxis = TRUE,
wholenumbers=T, labelEnds=T,las=1, at=NULL) {
fg <- par("fg")
if(is.null(at)){
#get range on axis
if(side ==1 | side ==3) {
r <- par("usr")[1:2] #upper and lower limits of x-axis
} else {
r <- par("usr")[3:4] #upper and lower limits of y-axis
}
#make pertty intervals
at <- pretty(r)
#drop ends if desirbale
if(!labelEnds)
at <- at[at > r[1] & at < r[2]]
}
#restrict to whole numbers if desriable
if(wholenumbers)
at<-at[is.wholenumber(at)]
lab <- do.call(expression, lapply(at, function(i) bquote(10^.(i))))
#convert at if
if(baseAxis)
at<-10^at
#make labels
if ( labels )
axis(side, at=at, lab, col=if(horiz) fg else NA,
col.ticks=fg, las=las)
else
axis(side, at=at, FALSE, col=if(horiz) fg else NA,
col.ticks=fg, las=las)
}
##
##' @export
fun.plot.colors.density <- function(x,y,...){
mat <- cbind(x,y)
data <- as.data.frame(mat)
colors.dens <- densCols(mat)
plot(x,y, col=colors.dens, pch=20,...)
}
##' @export
fun.points.colors.density <- function(x,y,...){
mat <- cbind(x,y)
data <- as.data.frame(mat)
colors.dens <- densCols(mat)
points(x,y, col=colors.dens, pch=20,...)
}
##' @export
fun.boxplot.breaks <- function(x,y,Nclass=15,add=TRUE,...){
x1 <- x[!is.na(x) & !is.na(y)]
y1 <- y[!is.na(x) & !is.na(y)]
x <- x1
y <- y1
breakss <- seq(min(x),max(x),length=Nclass+1)
x.cut <- cut(x,breakss)
mid.points <- breakss[-(Nclass+1)]+abs(breakss[2]-breakss[1])/2
if(add){boxplot(y~x.cut,at=mid.points,outline=FALSE,add=add,names=NULL,
col=grey(1-table(x.cut)/length(x.cut)),
boxwex=(breakss[2]-breakss[1])*0.9,
pars=list(xaxt='n',axes=FALSE),...)
141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210
}else{
boxplot(y~x.cut,at=mid.points,outline=FALSE,names=round(mid.points,0),
boxwex=(breakss[2]-breakss[1])*0.9,
col=grey(1-table(x.cut)/length(x.cut)),...)
}
}
## function to overlay points on biomes
##' @export
##' @import sp
fun.overly.plot.on.biomes <- function(MAP, MAT, names.vec, poly = poly.DF){
xy = cbind(MAP, MAT)
dimnames(xy)[[1]] = names.vec
pts = SpatialPoints(xy)
return(over(pts, poly))
}
## We need to load sp here for the plot.poly method.
##' @export
##' @import sp
plot.biome.map <- function(poly = poly.DF){
# MAKE EMPTY PLOT
plot(0,0, type = 'n', xlim = c(0, 450), ylim = c(30, -15),
xlab = "Mean annual precipitation (cm)",
ylab = "Mean annual temperature (deg C)")
# MAKE POLYGONS
plot(poly,col = make.transparent(c("navajowhite3", "darkgoldenrod1",
"sienna","darkolivegreen4",
"darkseagreen3", "forestgreen",
"darkgreen","olivedrab","gray"),
0.9),
border = NA,
add = TRUE)
}
##' @export
plot.points.on.biome.map.diff.tropical <- function(MAP, MAT, set,ecocode,
cols = niceColors(),
add.legend=TRUE){
plot.biome.map()
col <- c()
pch <- c()
cex <- c()
sets <- unique(set)
for(i in 1:length(sets)){
j <- (set == sets[i])
if(unique(ecocode[j])[1]=='tropical') {
col <- c(col,make.transparent(cols[i],0.75))
pch <- c(pch,16)
cex <- c(cex,1.25)
points(MAP[j], MAT[j], pch = pch[i], col = col[i], cex=cex[i])
}else{
col <- c(col,make.transparent(cols[i],0.25))
pch <- c(pch,16)
cex <- c(cex,.25)
points(MAP[j], MAT[j], pch = pch[i], col = col[i], cex=cex[i])
}
}
if(add.legend)
legend("topright", pch = pch, legend = sets, bty = "n", col = col, cex = 1)
}
##' @export
plot.points.on.biome.map.ecocode <- function(MAP, MAT, MAP.sd, MAT.sd, set,
ecocode, cols = niceColors(),
add.legend = TRUE){
211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280
plot.biome.map()
col <- c()
pch <- c()
cex <- c()
sets <- unique(set)
for(i in 1:length(sets)){
j <- (set == sets[i])
col <- c(col,make.transparent(cols[i],0.99))
pch <- c(pch,16)
cex <- c(cex,1.25)
points(MAP[j], MAT[j], pch = pch[i], col = col[i], cex=cex[i])
segments(MAP[j], MAT[j]-MAT.sd[j],MAP[j], MAT[j]+MAT.sd[j], col = col[i])
segments(MAP[j]-MAP.sd[j], MAT[j],MAP[j]+MAP.sd[j], MAT[j], col = col[i])
}
if(add.legend)
legend("topright", pch = pch, legend = sets, bty = "n", col = col, cex = 1)
}
##' @export
plot.points.on.biome.map <- function(MAP, MAT, set, cols = col.vec){
plot.biome.map()
points(MAP, MAT, col = cols[set])
}
##' @export
plot.points.on.biome.map.panel <- function(MAP, MAT, set, ecocode,
cols = niceColors()[-c(1)]){
sets <- unique(set)
nsets <- length(sets)
par(mfrow=c(ceiling(nsets/2),2), mar = c(4,3,3,2))
for(i in 1:nsets){
j <- (set == sets[i])
plot.points.on.biome.map(MAP[j], MAT[j], set[j])
title(sets[i])
}
}
##' @export
plot.ellips.on.biome.map <- function(MAP, MAT, set,
cols = col.vec, lty.vec = pch.vec){
plot.biome.map()
lapply(unique(set), fun.ellipsoid.hull,
x = MAP, y = MAT, sets.v = set,
col.vec = cols, lty.vec = lty.vec)
legend("topright", pch = 16, legend = names(col.vec), bty = "n",
col = col.vec, ncol = 2)
}
##' @export
fun.ellipsoid.hull <- function(set, x, y, sets.v, col.vec, lty.vec){
xy <- cbind(x[sets.v==set], y[sets.v==set])
if (nrow(xy)>10){
xy <- xy[!is.na(xy[, 1]) & !is.na(xy[, 2]), ]
xy <- xy[xy[, 1]>quantile(xy[, 1], 0.01) &xy[, 1]<quantile(xy[, 1], 0.99) &
xy[, 2]>quantile(xy[, 2], 0.01) &xy[, 2]<quantile(xy[, 2], 0.99), ]
exy <- cluster::ellipsoidhull(xy)
lines(predict(exy), col = col.vec[set], lwd = 3)
}else{
points(x[sets.v==set], y[sets.v==set] , col = col.vec[set],
cex = 2.5, pch = 16)
}
}
281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350
##' @export
prepare.plotting.info <- function() {
## vector of colors for set with name to have always teh same colors
sets <- c("BCI","Canada","France","Fushan","Japan","Luquillo","Mbaiki",
"NSW","NVS","Paracou",
"Spain","Sweden","Swiss","US")
col.vec <- niceColors(length(sets))
names(col.vec) <- sets
pch.vec <- 1:length(sets)
names(pch.vec) <- sets
### PLOTS function for biomes
biomes.data <- read.csv(system.file("extdata/biomes.csv",
package="traitcompetition"),
stringsAsFactors = FALSE)
list.coord <- lapply(unique(biomes.data$biome),
function(biome.id,data)
cbind(data$y[data$biome == biome.id] * 10,
data$x[data$biome == biome.id]),
data=biomes.data)
names(list.coord) <- unique(biomes.data$biome)
list.Polygon <- lapply(list.coord, Polygon)
list.Polygons <- lapply(1:length(list.Polygon),
function(i, x) {Polygons(list(x[[i]]), names(x)[i])},
x = list.Polygon)
poly.biomes <- sp::SpatialPolygons(list.Polygons)
DF <- data.frame(biomes= names(poly.biomes), row.names = names(poly.biomes))
poly.DF <- sp::SpatialPolygonsDataFrame(poly.biomes, DF)
## creat object for polygon of whitaker
list.poly <-
list(tropical_rainforest = cbind(x = c(260,450,350,250,260),
y = c(30,30,20,20,30)),
temperate_rainforest = cbind(x = c(250,350,200,160,250),
y = c(20,20,5,5,20)),
tropical_montane_forest = cbind(x = c(160,200,150,120,160),
y = c(5,5,0,0,5)),
alpine_shrubland = cbind(x = c(120,150,100,80,120),
y = c(0,0,-5,-5,0)),
tropical_deciduous_forest = cbind(x = c(140,260,250,130,140),
y = c(30,30,20,20,30)),
temperate_forest = cbind(x = c(130,250,160,60,130),
y = c(20,20,5,3,20)),
boreal = cbind(x = c(60,160,80,50,60),
y = c(3,5,-5,-5,3) ),
tropical_woodland = cbind(x = c(50,140,130,37,50),
y = c(30,30,20,20,30) ),
temperate_woodland = cbind(x = c(37,130,60,50,0,37),
y = c(20,20,3,-5,-5,20)),
cold_desert = cbind(x = c(0,23,0,0),
y = c(10,10,-5,10)),
hot_desert = cbind(x = c(0,50,23,0,0),
y = c(30,30,10,10,30)),
tundra = cbind(x = c(0,100,0,0),
y = c(-5,-5,-15,-5)))
list.Polygon <- lapply(list.poly, Polygon)
list.Polygons <- lapply(1:length(list.Polygon),
function(i, x) {Polygons(list(x[[i]]), names(x)[i])},
x = list.Polygon)
poly.biomes <- sp::SpatialPolygons(list.Polygons)
DF <- data.frame(biomes= names(poly.biomes), row.names = names(poly.biomes))
poly.DF2 <- sp::SpatialPolygonsDataFrame(poly.biomes, DF)
col.vec.biomes <- make.transparent(c("navajowhite3", "darkgoldenrod1",
351352353354355356357358359360361362363364365
"sienna","darkolivegreen4",
"darkseagreen3", "forestgreen",
"darkgreen","olivedrab","gray"),
0.9)
names(col.vec.biomes) <- poly.DF$biomes
pch.vec.biomes <-1:length(poly.DF$biomes)
names(pch.vec.biomes) <- poly.DF$biomes
list(pch=pch.vec,
col=col.vec,
col.biomes=col.vec.biomes,
pch.vec.biomes=pch.vec.biomes,
poly.DF=poly.DF)
}