Nothing
# Author: Babak Naimi, naimi.b@gmail.com
# Date (last update): Feb 2024
# Version 3.3
# Licence GPL v3
#---------------------
if (!isGeneric("plot")) {
setGeneric("plot", function(x,y,...)
standardGeneric("plot"))
}
setMethod("plot", signature(x='sdmEvaluate'),
function(x,y,smooth=TRUE,...) {
if (missing(y)) y <- 'roc'
else {
ar <- c('roc','sensitivity','specificity','TSS','Kappa','NMI','phi','ppv','npv','ccr','mcr','or','ommission','commission','predicted.prevalence')
y <- .pmatch(y,ar)[1]
if (is.na(y)) stop('when x is a sdmEvaluate object, y should be a statistic to plot, the name in the y is not recognised!')
}
if (!.sdmOptions$getOption('sdmLoaded')) .addMethods()
if (y == 'roc') {
r <- .roc(x@observed,x@predicted)
.plot.roc(r,auc=x@statistics$AUC,smooth=smooth,...)
} else {
r <- .getEvalThresholds(x@observed,x@predicted,y)
mx <- r[which.max(r[,2]),1]
if (smooth) {
rr <- try(supsmu(r[,1],r[,2],bass=0),silent=TRUE)
if (!inherits(rr,'try-error')) {
r <- rr
rm(rr)
}
}
dot <- list(...)
ndot <- names(dot)
dot[['x']] <- r
if (!'xlab' %in% ndot) dot[['xlab']] <- 'Thresholds'
if (!'ylab' %in% ndot) dot[['ylab']] <- y
if (!'main' %in% ndot) dot[['main']] <- paste('max at:',round(mx,2))
if (!'type' %in% ndot) dot[['type']] <- 'l'
do.call(plot,dot)
}
}
)
#----------------
setMethod("plot", signature(x='sdmdata'),
function(x,y,sp=NULL,test=FALSE,col=c('blue','red'),xlab,ylab,main,xlim,ylim,pch,...) {
xy <- coords(x)
if (missing(y)) {
if (!is.null(xy)) y <- 'map'
else y <- NULL
} else y <- tolower(y)
if (missing(test)) test <- FALSE
if (missing(sp)) {
sp <- x@species.names
} else {
if (numeric(sp)) sp <- x@species.names[sp]
}
np <- length(sp)
if (y == 'map') {
if (is.null(xy)) stop('the species train data does not contain coordinates, chnage y for the other plots')
else xy <- data.frame(x@info@coords)
if (missing(xlab)) xlab <- 'X'
if (missing(ylab)) ylab <- 'Y'
if (missing(pch)) pch <- c(16,16)
if (length(col) == 1) col <- rep(col,2)
if (length(pch) == 1) pch <- rep(pch,2)
rx <- range(xy[,2])
xadd <- (rx[2] - rx[1]) * 0.01
ry <- range(xy[,3])
yadd <- (ry[2] - ry[1])*0.01
if (missing(xlim)) xlim <- rx + (xadd*c(-1,1))
if (missing(ylim)) ylim <- ry + (yadd*c(-1,1))
if (missing(main)) main <- 'presence/absence map'
if (np > 16) {
warning('Due to larger number of plots, only the first 16 species are used...')
sp <- sp[1:16]
par(mfrow=c(4,4))
} else {
w <- floor(sqrt(np))
h <- ceiling(np/w)
if (abs(w-h) > 1) {
w <- w+1
h <- h-1
}
par(mfrow=c(w,h))
}
for (s in sp) {
df <- as.data.frame(x,sp=s,grp=if(test) 'test' else NULL)
w <- xy$rID %in% df$rID
if (x@species[[sp]]@type == 'Presence-Absence') {
w1 <- df[,s] == 1
plot(xy[w1 & w,2:3],xlim=xlim,ylim=ylim,xlab=xlab,ylab=ylab,col=col[1],main=paste(main,'_',s),pch=pch[1],...)
w1 <- !w1
points(xy[w1 & w,2:3],col=col[2],pch=pch[2],...)
} else {
plot(xy[w,2:3],xlim=xlim,ylim=ylim,xlab=xlab,ylab=ylab,col=col[1],main=paste(main,'_',s),pch=pch[1],...)
}
}
}
}
)
setMethod("plot", signature(x='.sdmCalibration'),
function(x,y,...) {
if (missing(y)) y <- NULL
dot <- list(...)
ndot <- names(dot)
if (!'xlab' %in% ndot) dot[['xlab']] <- "Predicted Probability of Occurrence"
if (!'ylab' %in% ndot) dot[['ylab']] <- "Proportion of Observed Occurrences"
if (!'xlim' %in% ndot) dot[['xlim']] <- c(0,1)
if (!'ylim' %in% ndot) dot[['ylim']] <- c(0,1)
if (!'main' %in% ndot) dot[['main']] <- 'Calibration Plot'
if (!'sub' %in% ndot) dot[['sub']] <- paste('statistic = ',round(x@statistic,3),sep='')
if ('cex' %in% ndot) {
cex <- dot[['cex']]
w <- which(ndot == 'cex')
dot <- dot[-w]
ndot <- ndot[-w]
} else cex <- 2
if ('pch' %in% ndot) {
pch <- dot[['pch']]
w <- which(ndot == 'pch')
dot <- dot[-w]
ndot <- ndot[-w]
} else pch <- 16
dot[['x']] <- 2
dot[['y']] <- 1
do.call(plot,dot)
abline(a=0,b=1,lty=2)
points(x@calibration[,1:2],pch=16,cex=2)
#legend(0.7,0.05,legend = paste('Calibration = ',round(o@statistic,3),sep=''),text.width=0.3)
}
)
#-------
setMethod("plot", signature(x='.varImportance'),
function(x,y,...) {
if (missing(y)) y <- 'corTest'
else {
y <- y[1]
if (is.character(y)) y <- .pmatch(y,c('corTest','AUCtest'))
else if (is.numeric(y)) {
if (!y %in% c(1,2)) {
y <- 'corTest'
warning('y should be 1 or 2, it is changed to 1 (i.e., corTest)')
} else y <- c('corTest','AUCtest')[y]
} else {
y <- 'corTest'
warning('y is not identified... default is used (i.e., corTest)')
}
}
dot <- list(...)
ndot <- names(dot)
if (!'xlab' %in% ndot) dot[['xlab']] <- "Relative Variable Importance"
if (!'horiz' %in% ndot) dot[['horiz']] <- TRUE
if (!'names.arg' %in% ndot) dot[['names.arg']] <- x@variables
if (!'col' %in% ndot) dot[['col']] <-'#DDE9EB'
if (!'cex.names' %in% ndot) dot[['cex.names']] <- 0.8
if (!'las' %in% ndot) dot[['las']] <- 1
dot[['height']] <- x@varImportance[,y]
do.call(barplot,dot)
}
)
#-------
setMethod("plot", signature(x='.varImportanceList'),
function(x,y,gg=TRUE,confidence=TRUE,...) {
if (missing(gg)) gg <- TRUE
if (missing(confidence)) confidence <- TRUE
if (gg && !.require('ggplot2')) gg <- FALSE
if (missing(y)) y <- 'corTest'
else {
y <- y[1]
if (is.character(y)) y <- .pmatch(y,c('corTest','AUCtest'))
else if (is.numeric(y)) {
if (!y %in% c(1,2)) {
y <- 'corTest'
warning('y should be 1 or 2, it is changed to 1 (i.e., corTest)')
} else y <- c('corTest','AUCtest')[y]
} else {
y <- 'corTest'
warning('y is not identified... default is used (i.e., corTest)')
}
}
dot <- list(...)
ndot <- names(dot)
if (gg) {
drcc <- x@varImportanceMean[[y]]
if (!'horiz' %in% ndot) horiz <- TRUE
else horiz <- dot[['horiz']]
if (!'xlab' %in% ndot) xlab <- "Variables"
else xlab <- dot[['xlab']]
if (!'ylab' %in% ndot) ylab <- "Relative Variable Importance"
else ylab <- dot[['ylab']]
if (!'col' %in% ndot) col <-'#9966CC'
else col <- dot[['col']]
if (!'main' %in% ndot) main <- 'Relative Variable Importance'
else main <- dot[['main']]
if (y == 'corTest') {
if (horiz) {
if (confidence) {
p2 <- "ggplot(drcc,aes(x=variables,y=corTest)) + geom_bar(stat = 'identity',fill=col) + geom_errorbar(aes(ymin=lower, ymax=upper),width=.3,position=position_dodge(.9)) +
coord_flip() + labs(y = ylab,x = xlab) + ggtitle(main)"
} else {
p2 <- "ggplot(drcc,aes(x=variables,y=corTest)) + geom_bar(stat = 'identity',fill=col) +
coord_flip() + labs(y = ylab,x = xlab) + ggtitle(main)"
}
} else {
if (confidence) {
p2 <- "ggplot(drcc,aes(x=variables,y=corTest)) + geom_bar(stat = 'identity',fill=col) + geom_errorbar(aes(ymin=lower, ymax=upper),width=.3,position=position_dodge(.9)) +
labs(y = ylab,x = xlab) + ggtitle(main)"
} else {
p2 <- "ggplot(drcc,aes(x=variables,y=corTest)) + geom_bar(stat = 'identity',fill=col) +
labs(y = ylab,x = xlab) + ggtitle(main)"
}
}
} else {
if (horiz) {
if (confidence) {
p2 <- "ggplot(drcc,aes(x=variables,y=AUCtest)) + geom_bar(stat = 'identity',fill=col) + geom_errorbar(aes(ymin=lower, ymax=upper),width=.3,position=position_dodge(.9)) +
coord_flip() + labs(y = ylab,x = xlab) + ggtitle(main)"
} else {
p2 <- "ggplot(drcc,aes(x=variables,y=AUCtest)) + geom_bar(stat = 'identity',fill=col) +
coord_flip() + labs(y = ylab,x = xlab) + ggtitle(main)"
}
} else {
if (confidence) {
p2 <- "ggplot(drcc,aes(x=variables,y=AUCtest)) + geom_bar(stat = 'identity',fill=col) + geom_errorbar(aes(ymin=lower, ymax=upper),width=.3,position=position_dodge(.9)) +
labs(y = ylab,x = xlab) + ggtitle(main)"
} else {
p2 <- "ggplot(drcc,aes(x=variables,y=AUCtest)) + geom_bar(stat = 'identity',fill=col) +
labs(y = ylab,x = xlab) + ggtitle(main)"
}
}
}
p2 <- .eval(p2,env=environment())
return(p2)
} else {
if (!'xlab' %in% ndot) dot[['xlab']] <- "Relative Variable Importance"
if (!'horiz' %in% ndot) dot[['horiz']] <- TRUE
if (!'names.arg' %in% ndot) dot[['names.arg']] <- x@variables
if (!'col' %in% ndot) dot[['col']] <-'#DDE9EB'
if (!'cex.names' %in% ndot) dot[['cex.names']] <- 0.8
if (!'las' %in% ndot) dot[['las']] <- 1
if (dot[['horiz']]) {
if (!'xlim' %in% ndot) dot[['xlim']] <- c(0,max(x@varImportanceMean[[y]][,4],na.rm=TRUE))
} else {
if (!'ylim' %in% ndot) dot[['ylim']] <- c(0,max(x@varImportanceMean[[y]][,4],na.rm=TRUE))
}
dot[['height']] <- x@varImportanceMean[[y]][,2]
.bar <- do.call(barplot,dot)
if (confidence) {
if (dot[['horiz']]) {
segments(x@varImportanceMean[[y]][,3], .bar,x@varImportanceMean[[y]][,4], .bar, lwd = 1.5)
arrows(x@varImportanceMean[[y]][,3], .bar,x@varImportanceMean[[y]][,4], .bar, lwd = 1.5, angle = 90,code = 3, length = 0.05)
} else {
segments(.bar,x@varImportanceMean[[y]][,3], .bar,x@varImportanceMean[[y]][,4], lwd = 1.5)
arrows(.bar,x@varImportanceMean[[y]][,3], .bar,x@varImportanceMean[[y]][,4], lwd = 1.5, angle = 90,code = 3, length = 0.05)
}
}
}
}
)
#-------
setMethod("plot", signature(x='.responseCurve'),
function(x,y,gg=TRUE,mean=TRUE,confidence=TRUE,xlab,ylab,ylim,lty,lwd,col,cex.axis,cex.lab,main,...) {
if (gg && !.require('ggplot2')) gg <- FALSE
if (missing(mean)) mean <- TRUE
if (missing(confidence)) confidence <- TRUE
if (missing(y) || is.null(y)) n <- x@variables
else {
n <- y
n <- n[n %in% x@variables]
if (length(n) == 0) stop('the specified variable(s) in n does not exist in the responseCurve object!')
}
if (!is.null(x@categorical)) {
nF <- x@categorical
nF <- nF[nF %in% n]
if (length(nF) == 0) nF <- NULL
n <- .excludeVector(n,nF)
} else nF <- NULL
#-------
if (missing(xlab)) xlab <- 'Variables'
if (missing(ylab)) ylab <- 'Response'
if (missing(lty)) lty <- 1
if (missing(col)) col <- '#00395F'
if (missing(lwd)) lwd <- 1
if (missing(cex.axis)) cex.axis <- 1
if (missing(cex.lab)) cex.lab <- 1
if (missing(main)) main <- 'Response Curve'
if (missing(ylim)) ylim <- NULL
#--------
if (gg) {
if (x@multi) {
if (mean) {
if (confidence) {
drc <- data.frame(Value=0,Response=0,lower=0,upper=0,variable='a')[0,]
for (nn in n) {
.n <- length(x@response[[nn]][,1])
.m <- apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,mean,na.rm=TRUE)
.ci <- 1.96 * apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,sd,na.rm=TRUE) / sqrt(.n)
drc <- rbind(drc,data.frame(Value=x@response[[nn]][,1],Response=.m,lower=.m - .ci,upper=.m + .ci,variable=nn))
}
p1 <- "ggplot(drc,aes(x=Value,y=Response)) + geom_line(colour=col,size=lwd,linetype=lty) + geom_ribbon(aes(ymin=lower, ymax=upper), linetype=1, alpha=0.2) +
facet_grid(.~variable,scales='free_x') + labs(y = ylab,x = xlab) + ggtitle(main) +
theme(axis.text=element_text(size=rel(cex.axis)),axis.title=element_text(size=rel(cex.lab)),plot.title = element_text(hjust = 0.5))"
p1 <- .eval(p1,env=environment())
if (!is.null(nF)) {
drcc <- data.frame(Value=0,Response=0,variable='a')[0,]
for (nn in nF) {
.n <- length(x@response[[nn]][,1])
.m <- apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,mean,na.rm=TRUE)
.ci <- 1.96 * apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,sd,na.rm=TRUE) / sqrt(.n)
drcc <- rbind(drcc,data.frame(Value=x@response[[nn]][,1],Response=.m,lower=.m - .ci,upper=.m + .ci,variable=nn))
}
p2 <- "ggplot(drcc,aes(x=Value,y=Response)) + geom_bar(stat = 'identity',fill=col) + facet_grid(.~variable,scale='free') +
geom_errorbar(aes(ymin=lower, ymax=upper),width=.3,position=position_dodge(.9)) +
labs(y = ylab,x = xlab)"
p2 <- .eval(p2,env=environment())
if (!.require('gridExtra')) {
warning('you need the package gridExtra to make the plots printed in a single page!')
return(list(p1,p2))
} else {
return(.eval("grid.arrange(p1,p2)",env=environment()))
}
} else return(p1)
} else {
drc <- data.frame(Value=0,Response=0,variable='a')[0,]
for (nn in n) {
drc <- rbind(drc,data.frame(Value=x@response[[nn]][,1],Response=apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,mean,na.rm=TRUE),variable=nn))
}
p1 <- "ggplot(drc,aes(x=Value,y=Response)) + geom_line(colour=col,size=lwd,linetype=lty) +
facet_grid(.~variable,scales='free_x') + scale_y_continuous(limits=ylim) + labs(y = ylab,x = xlab) + ggtitle(main) +
theme(axis.text=element_text(size=rel(cex.axis)),axis.title=element_text(size=rel(cex.lab)),plot.title = element_text(hjust = 0.5))"
p1 <- .eval(p1,env=environment())
if (!is.null(nF)) {
drcc <- data.frame(Value=0,Response=0,variable='a')[0,]
for (nn in nF) {
.n <- length(x@response[[nn]][,1])
.m <- apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,mean,na.rm=TRUE)
.ci <- 1.96 * apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,sd,na.rm=TRUE) / sqrt(.n)
drcc <- rbind(drcc,data.frame(Value=x@response[[nn]][,1],Response=.m,lower=.m - .ci,upper=.m + .ci,variable=nn))
}
p2 <- "ggplot(drcc,aes(x=Value,y=Response)) + geom_bar(stat = 'identity',fill=col)+ scale_y_continuous(name = ylab,limits=ylim) + facet_grid(.~variable,scale='free') + geom_errorbar(aes(ymin=lower, ymax=upper),width=.3,position=position_dodge(.9))"
p2 <- .eval(p2,env=environment())
if (!.require('gridExtra')) {
warning('you need the package gridExtra to make the plots printed in a single page!')
return(list(p1,p2))
} else {
return(.eval("grid.arrange(p1,p2)",env=environment()))
}
} else return(p1)
}
} else {
drc <- data.frame(variable='a',Value=0)[0,]
for (nn in n) {
drc <- rbind(drc,data.frame(variable=nn,Value=x@response[[nn]][,1],x@response[[nn]][,2:ncol(x@response[[nn]])]))
}
}
p1 <- ".p1 <- ggplot(drc,aes(x=Value)) + geom_line(aes_string(y=colnames(drc)[3]),colour=col,size=lwd,linetype=lty) +scale_y_continuous(name = ylab,limits = c(0,1)) + facet_grid(.~variable,scales='free_x')
for (nn in colnames(drc)[4:ncol(drc)]) .p1 <- .p1 + geom_line(aes_string(y=nn),colour=col,size=lwd,linetype=lty)"
.eval(p1,env=environment())
if (!is.null(nF)) {
drcc <- data.frame(Value=0,Response=0,variable='a')[0,]
for (nn in nF) {
.n <- length(x@response[[nn]][,1])
.m <- apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,mean,na.rm=TRUE)
.ci <- 1.96 * apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,sd,na.rm=TRUE) / sqrt(.n)
drcc <- rbind(drcc,data.frame(Value=x@response[[nn]][,1],Response=.m,lower=.m - .ci,upper=.m + .ci,variable=nn))
}
if (confidence) p2 <- "ggplot(drcc,aes(x=Value,y=Response)) + geom_bar(stat = 'identity',fill=col)+ scale_y_continuous(name = ylab,limits=ylim) + facet_grid(.~variable,scale='free') + geom_errorbar(aes(ymin=lower, ymax=upper),width=.3,position=position_dodge(.9))"
else p2 <- "ggplot(drcc,aes(x=Value,y=Response)) + geom_bar(stat = 'identity',fill=col)+ scale_y_continuous(name = ylab,limits=ylim) + facet_grid(.~variable,scale='free')"
p2 <- .eval(p2,env=environment())
if (!.require('gridExtra')) {
warning('you need the package gridExtra to make the plots printed in a single page!')
return(list(p1,p2))
} else {
return(.eval("grid.arrange(p1,p2)",env=environment()))
}
} else return(p1)
} else {
drc <- data.frame(Value=0,Response=0,variable='a')[0,]
for (nn in n) {
colnames(x@response[[nn]]) <- c('Value','Response')
drc <- rbind(drc,data.frame(x@response[[nn]],variable=nn))
}
p1 <- "ggplot(drc,aes(x=Value,y=Response)) + geom_line(colour=col,size=lwd,linetype=lty) + facet_grid(.~variable,scales='free_x') +
scale_y_continuous(limits=ylim) + labs(y = ylab,x = xlab) + ggtitle(main) +
theme(axis.text=element_text(size=rel(cex.axis)),axis.title=element_text(size=rel(cex.lab)),plot.title = element_text(hjust = 0.5))"
p1 <- .eval(p1,env=environment())
if (!is.null(nF)) {
drcc <- data.frame(Variable=0,Response=0)[0,]
for (nn in nF) {
colnames(x@response[[nn]]) <- c('Variable','Response')
drcc <- rbind(drcc,data.frame(x@response[[nn]],variable=nn))
}
p2 <- "ggplot(drcc,aes(x=Variable,y=Response)) + geom_bar(stat = 'identity',fill=col) + facet_grid(.~variable,scale='free')"
p2 <- .eval(p2,env=environment())
if (!.require('gridExtra')) {
warning('you need the package gridExtra to make the plots printed in a single page!')
return(list(p1,p2))
} else {
pp <- .eval("grid.arrange(p1,p2)",env=environment())
return(pp)
}
} else return(p1)
}
} else {
np <- length(n) + length(nF)
if (np > 16) {
warning('Due to larger number of variables, only the plots for the first 16 variables are generated!')
if (length(n) >= 16) {
n <- n[1:16]
nF <- NULL
} else {
nF <- nF[1:(16 - length(n))]
}
par(mfrow=c(4,4),mar=c(5,4,1,1))
} else {
w <- floor(sqrt(np))
h <- ceiling(np/w)
if (abs(w-h) > 1) {
w <- w+1
h <- h-1
}
par(mfrow=c(w,h),mar=c(5,4,1,1))
}
#===========
if (x@multi) {
for (nn in n) {
if (mean) {
.m <- apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,mean,na.rm=TRUE)
plot(x@response[[nn]][,1],.m,type='l',xlab=nn,col=col,main=main,cex.axis=cex.axis,cex.lab=cex.lab,ylab=ylab,ylim=ylim,...)
if (confidence) {
.n <- length(x@response[[nn]][,1])
.ci <- 1.96 * apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,sd,na.rm=TRUE) / sqrt(.n)
lines(x@response[[nn]][,1],.m - .ci,col='gray',lty=2,lwd=lwd)
lines(x@response[[nn]][,1],.m + .ci,col='gray',lty=2,lwd=lwd)
}
} else {
plot(x@response[[nn]][,1:2],type='l',xlab=nn,col=col,main=main,cex.axis=cex.axis,cex.lab=cex.lab,ylab=ylab,ylim=ylim,...)
for (i in 3:ncol(x@response[[nn]])) lines(x@response[[nn]][,1],x@response[[nn]][,i],col=col,lwd=lwd)
}
}
if (!is.null(nF)) {
for (nn in nF) {
.m <- apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,mean,na.rm=TRUE)
.bar <- barplot(.m,xlab=nn,col=col,main=main,cex.axis=cex.axis,cex.lab=cex.lab,ylab=ylab,ylim=ylim)
if (confidence) {
.n <- length(x@response[[nn]][,1])
.ci <- 1.96 * apply(x@response[[nn]][,2:ncol(x@response[[nn]])],1,sd,na.rm=TRUE) / sqrt(.n)
segments(.bar, .m - .ci, .bar,.m + .ci, lwd = 1.5)
arrows(.bar, .m - .ci, .bar,.m + .ci, lwd = 1.5, angle = 90,code = 3, length = 0.05)
}
}
}
} else {
for (nn in n) {
plot(x@response[[nn]],type='l',xlab=nn,col=col,main=main,cex.axis=cex.axis,cex.lab=cex.lab,ylab=ylab,ylim=ylim,...)
}
if (!is.null(nF)) {
for (nn in nF) {
barplot(x@response[[nn]][,2],xlab=nn,col=col,main=main,cex.axis=cex.axis,cex.lab=cex.lab,ylab=ylab,ylim=ylim)
}
}
}
}
}
)
#--------
setMethod("plot", signature(x='.nicheRaster'),
function(x,y=NULL,gg=TRUE,rnd=1,xlab,ylab,col,cex.axis,cex.lab,main,...) {
if (missing(gg)) gg <- .require('ggplot2')
else if (gg && !.require('ggplot2')) gg <- FALSE
if (missing(xlab)) xlab <- x@names[1]
if (missing(ylab)) ylab <- x@names[2]
if (missing(col)) col <- c('darkred','red','yellow','green','darkgreen','darkblue')
if (missing(cex.axis)) cex.axis <- 0.8
if (missing(cex.lab)) cex.lab <- 1
if (missing(rnd)) rnd <- 1
if (missing(main)) main <- paste0('Ecological Niche described by: ',x@names[1],' - ',x@names[2])
.lab1 <- round(as.vector(seq(x@scaleParams[1,1], x@scaleParams[2,1], length.out = 6)),rnd)
.lab2 <- round(as.vector(seq(x@scaleParams[1,2], x@scaleParams[2,2], length.out = 6)),rnd)
#--------
if (gg) {
drc <- as.data.frame(x@nicheRaster,xy=TRUE)
p1 <- "ggplot(drc,aes(x=x,y=y,fill=niche)) +geom_raster() + coord_quickmap() +
scale_y_continuous(breaks=seq(0, 1, length.out = 6),name = ylab,labels=.lab2) + scale_x_continuous(breaks=seq(0, 1, length.out = 6),name = xlab,labels=.lab1) + ggtitle(main) +
scale_fill_gradientn(colours=col,na.value='white') + theme_bw() +
theme(axis.text=element_text(size=rel(cex.axis)),axis.title=element_text(size=rel(cex.lab)),plot.title = element_text(hjust = 0.5))"
p1 <- .eval(p1,env=environment())
return(p1)
} else {
if (length(col) < 10) col <- colorRampPalette(col)(100)
plot(x@nicheRaster,col=col,xaxt='n',yaxt='n',xlab=xlab,ylab=ylab,main=main,cex.axis=cex.axis,cex.lab=cex.lab,...)
axis(1, at=seq(0, 1, length.out = 6), labels = FALSE)
text(seq(0, 1, length.out = 6),par("usr")[3] - 0.05, labels = .lab1, srt = 0, pos = 1, xpd = TRUE,cex=cex.axis)
axis(2, at=seq(0, 1, length.out = 6), labels = FALSE)
text(par("usr")[1]-0.1,seq(0, 1, length.out = 6)+0.05, labels = .lab2, srt = 0, pos = 1, xpd = TRUE,cex=cex.axis)
}
}
)
#----
setMethod("plot", signature(x='.nicheSpatRaster'),
function(x,y=NULL,gg=TRUE,rnd=1,xlab,ylab,col,cex.axis,cex.lab,main,...) {
if (missing(gg)) gg <- .require('ggplot2')
else if (gg && !.require('ggplot2')) gg <- FALSE
if (missing(xlab)) xlab <- x@names[1]
if (missing(ylab)) ylab <- x@names[2]
if (missing(col)) col <- c('darkred','red','yellow','green','darkgreen','darkblue')
if (missing(cex.axis)) cex.axis <- 0.8
if (missing(cex.lab)) cex.lab <- 1
if (missing(rnd)) rnd <- 1
if (missing(main)) main <- paste0('Ecological Niche described by: ',x@names[1],' - ',x@names[2])
.lab1 <- round(as.vector(seq(x@scaleParams[1,1], x@scaleParams[2,1], length.out = 6)),rnd)
.lab2 <- round(as.vector(seq(x@scaleParams[1,2], x@scaleParams[2,2], length.out = 6)),rnd)
#--------
if (gg) {
drc <- as.data.frame(x@nicheRaster,xy=TRUE,na.rm=FALSE)
p1 <- "ggplot(drc,aes(x=x,y=y,fill=niche)) +geom_raster() + coord_quickmap() +
scale_y_continuous(breaks=seq(0, 1, length.out = 6),name = ylab,labels=.lab2) + scale_x_continuous(breaks=seq(0, 1, length.out = 6),name = xlab,labels=.lab1) + ggtitle(main) +
scale_fill_gradientn(colours=col,na.value='white') + theme_bw() +
theme(axis.text=element_text(size=rel(cex.axis)),axis.title=element_text(size=rel(cex.lab)),plot.title = element_text(hjust = 0.5))"
p1 <- .eval(p1,env=environment())
return(p1)
} else {
if (length(col) < 10) col <- colorRampPalette(col)(100)
plot(x@nicheRaster,col=col,xaxt='n',yaxt='n',xlab=xlab,ylab=ylab,main=main,cex.axis=cex.axis,cex.lab=cex.lab,...)
axis(1, at=seq(0, 1, length.out = 6), labels = FALSE)
text(seq(0, 1, length.out = 6),par("usr")[3] - 0.05, labels = .lab1, srt = 0, pos = 1, xpd = TRUE,cex=cex.axis)
axis(2, at=seq(0, 1, length.out = 6), labels = FALSE)
text(par("usr")[1]-0.1,seq(0, 1, length.out = 6)+0.05, labels = .lab2, srt = 0, pos = 1, xpd = TRUE,cex=cex.axis)
}
}
)
#--------
if (!isGeneric("boxplot")) {
setGeneric("boxplot", function(x, ...)
standardGeneric("boxplot"))
}
setMethod('boxplot', signature(x='sdmEvaluate'),
function(x,notch = FALSE,col='#DDE9EB',names,...) {
p <- x@predicted
x <- x@observed
w <- which(!is.na(p))
p <- p[w]; x <- x[w]
w <- which(!is.na(x))
p <- p[w]; x <- x[w]
w1 <- which(x == 1)
w2 <- which(x == 0)
if (length(w1) > 0) {
if (length(w2) > 0) {
if (missing(names)) names <- c('Absence','Presence')
boxplot(p[w2],p[w1],notch=notch,names=names,col=col,...)
} else {
if (missing(names)) names <-'Absence'
boxplot(p[w2],notch=notch,col=col,...)
}
} else {
if (length(w2) > 0) {
if (missing(names)) names <- 'Presence'
boxplot(p[w1],notch=notch,names=names,col=col,...)
}
}
}
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.