##' spplot1 function
##'
##' A function to provide spplot-like plotting capability but NOT using trellis graphics. This function also acts as an interface for fast
##' plotting of SpatialPolygonsDataFrame or SpatialPixelsDataFrame objects using leaflet HTML plotting capabilities to get zoomable plots
##' with real-world context: transformation to the correct projection is done automatically.
##'
##' See \url{http://leaflet-extras.github.io/leaflet-providers/preview/} for examples of leaflet templates.
##'
##' Instructions on installing the leaflet R package are available from \url{https://rstudio.github.io/leaflet/}
##'
##' @param x a SpatialPolgonsDataFrame or a SpatialPointsDataFrame
##' @param what the name of the variable to plot
##' @param palette the palette, can either be a vector of names of colours, or a vector of colours produced for example by the brewer.pal function.
##' @param breaks optional breaks for the legend, a vector of length 1 + length(palette)
##' @param legpos the position of the legend, options are 'topleft', 'topright', 'bottomleft', 'bottomright'
##' @param fun an optional function of the data to plot, default is the identity function
##' @param include.lowest see ?cut
##' @param bty see ?legend
##' @param bg see ?legend
##' @param printlegend logical: print the legend?
##' @param bw Logical. Plot in black/white/greyscale? Default is to produce a colour plot. Useful for producing plots for journals that do not accept colour plots.
##' @param useLeaflet whether to use leaflet to produce a zoomable map this requires the leaflet package, available by issuing the command "devtools::install_github('rstudio/leaflet')"
##' @param urltemplate template for leaflet map background, default is urlTemplate('Stamen-Toner'), but any valid web address for leaflet templates will work here. See ?urlTemplate.
##' @param fillOpacity see ?addPolygons
##' @param legendOpacity see opacity argument in function addLegend
##' @param OSMbg optional OpenStreetMap background to add to plot, obtain this using the function getBackground
##' @param leafletLegend logical, display the leaflet legend?
##' @param alpha.f point transparency, see ?adjustcolor, default is 0.5
##' @param ... other arguments to be passed to plot
##' @return either produces a plot or if useLeaflet is TRUE, returns a leaflet map widget to which further layers can be added
##' @seealso \link{urlTemplate}, \link{getBackground}, brewer.pal
##' @export
spplot1 <- function(x,
what,
palette=brewer.pal(5,"Oranges"),
breaks=NULL,
legpos="topleft",
fun=identity,
include.lowest=TRUE,
bty="n",
bg=NULL,
printlegend=TRUE,
bw=FALSE,
useLeaflet=FALSE,
urltemplate=urlTemplate("Stamen_Toner"),
fillOpacity = 0.5,
legendOpacity = 0.5,
OSMbg=NULL,
leafletLegend=TRUE,
alpha.f=0.5,
...){
if(bw){
palette <- brewer.pal(5,"Greys")
}
n <- length(palette)
if(!is.null(breaks)){
if(length(breaks)!=(n+1)){
stop("Breaks must be a vector of length 1 + length(palette).")
}
}
if(is.numeric(x[[what]])){
tp <- fun(x[[what]]) # tp = to plot
if(is.null(breaks)){
cutt <- cut(tp,n,include.lowest=include.lowest)
}
else{
cutt <- cut(tp,breaks,include.lowest=include.lowest)
}
lvls <- levels(cutt)
cols <- palette[as.numeric(cutt)]
}
else if(is.factor(x[[what]])){
cutt <- as.numeric(x[[what]])
lvls <- levels(x[[what]])
if(length(lvls)!=length(palette)){
stop(paste("Number of levels in factor variable, ",what,", must have the same number of colours in palette.",sep=""))
}
cols <- palette[cutt]
}
else{
stop("Plotting variable must either be of class numeric, integer or factor.")
}
if(!useLeaflet){
if(is.null(OSMbg)){
sp::plot(x,col=cols,...)
}
else{
plot(OSMbg,...)
cols <- adjustcolor(cols,alpha.f=alpha.f)
palette <- adjustcolor(palette,alpha.f=alpha.f)
x <- spTransform(x,CRS("+init=epsg:3857"))
sp::plot(x,col=cols,add=TRUE,...)
}
if(printlegend){
lg <- legend(legpos,pch=rep(15,n),col=palette,legend=lvls,bty=bty,plot=FALSE)
polygon(c(lg[[1]]$left,lg[[1]]$left,lg[[1]]$left+lg[[1]]$w,lg[[1]]$left+lg[[1]]$w),c(lg[[1]]$top-lg[[1]]$h,lg[[1]]$top,lg[[1]]$top,lg[[1]]$top-lg[[1]]$h),border=NA,col=bg)
legend(legpos,pch=rep(15,n),col=palette,legend=lvls,bty=bty,bg=bg)
}
}
else{
m <- NULL
s <- "require(leaflet)
{
if(inherits(x,'SpatialPolygonsDataFrame')){
ns <- spTransform(x,CRS('+init=epsg:4326'))
m <- leaflet() %>%
addTiles(urlTemplate=urltemplate) %>%
addPolygons(data=ns,color=cols,fillColor=cols,weight=0,fillOpacity = fillOpacity,stroke=FALSE) %>%
addLegend(position='topright', labels = lvls, colors = palette,opacity=legendOpacity)
}
else if(inherits(x,'SpatialPointsDataFrame')){
ns <- spTransform(x,CRS('+init=epsg:4326'))
m <- leaflet() %>%
addTiles(urlTemplate=urltemplate) %>%
addCircleMarkers(data=ns,color=cols,stroke=FALSE) %>%
addLegend(position='topright', labels = lvls, colors = palette,opacity=legendOpacity)
}
else{
stop('Leaflet mapping for this kind of object not supported at present')
}
}
cat('Leaflet map returned, type name of object to visualise in a web browser.\n')"
if(!leafletLegend){
s <- "require(leaflet)
{
if(inherits(x,'SpatialPolygonsDataFrame')){
ns <- spTransform(x,CRS('+init=epsg:4326'))
m <- leaflet() %>%
addTiles(urlTemplate=urltemplate) %>%
addPolygons(data=ns,color=cols,fillColor=cols,weight=0,fillOpacity = fillOpacity,stroke=FALSE)
}
else if(inherits(x,'SpatialPointsDataFrame')){
ns <- spTransform(x,CRS('+init=epsg:4326'))
m <- leaflet() %>%
addTiles(urlTemplate=urltemplate) %>%
addCircleMarkers(data=ns,color=cols,stroke=FALSE)
}
else{
stop('Leaflet mapping for this kind of object not supported at present')
}
}
cat('Leaflet map returned, type name of object to visualise in a web browser.\n')"
}
eval(parse(text=s))
return(m)
}
}
##' spplot_compare function
##'
##' A function to compare two SpatialPolgonsDataFrame or SpatialPointsDataFrame objects using a unified legend for the variable
##' of interest in both
##'
##' @param x a SpatialPolgonsDataFrame or a SpatialPointsDataFrame
##' @param y a SpatialPolgonsDataFrame or a SpatialPointsDataFrame
##' @param what the name of the variable from x to plot
##' @param what1 the name of the variable from y to plot. default is to plot the variable of the same name
##' @param palette the palette, can either be a vector of names of colours, or a vector of colours produced for example by the brewer.pal function.
##' @param legpos the position of the legend, options are 'topleft', 'topright', 'bottomleft', 'bottomright'
##' @param border see ?spplot
##' @param fun an optional function of the data to plot, default is the identity function
##' @param t1 title for the plot of x
##' @param t2 title for the plot of y
##' @param bw Logical. Plot in black/white/greyscale? Default is to produce a colour plot. Useful for producing plots for journals that do not accept colour plots.
##' @param ... other arguments to be passed to the plot function
##' @return produces a plot comparing x[[what]] and y[[what1]]
##' @export
spplot_compare <- function(x,y,what,what1=what,palette=brewer.pal(9,"Oranges"),legpos="topleft",border=NA,fun=identity,t1="",t2="",bw=FALSE,...){
if(bw){
palette <- brewer.pal(5,"Greys")
}
n <- length(palette)
tpx <- fun(x[[what]])
tpy <- fun(y[[what1]])
tp <- c(tpx,tpy)
cutt <- cut(tp,n)
lvls <- levels(cutt)
cols <- palette[as.numeric(cutt)]
colsx <- cols[1:length(tpx)]
colsy <- cols[(length(tpx)+1):length(tp)]
#dev.new(height=6,width=12)
par(mfrow=c(1,2))
sp::plot(x,col=colsx,border=border,...)
legend(legpos,pch=rep(15,n),col=palette,legend=lvls,bty="n",cex=0.75)
title(t1)
sp::plot(y,col=colsy,border=border,...)
#legend(legpos,pch=rep(15,n),col=palette,legend=lvls,bty="n",cex=0.75)
title(t2)
par(mfrow=c(1,1))
}
##' getBackground function
##'
##' A function to
##'
##' @param poly a spatial object that can be transformed and the extent obtained using the bbox function.
##' @param type see ?openmap
##' @return ...
##' @export
getBackground <- function(poly,type="stamen-toner"){
poly <- spTransform(poly,CRS("+init=epsg:4326"))
bb <- bbox(poly)
map <- openmap(upperLeft=c(lat=bb[2,2],lon=bb[1,1]), lowerRight=c(lat=bb[2,1],lon=bb[1,2]),type=type)
return(map)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.