R/plottingfunctions.R

In spatsurv: Bayesian Spatial Survival Analysis with Parametric Proportional Hazards Models

## 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 plotinorder whether to plot in order of the size of the variable being plotted, useful for overlapping windows where small counts may obscure big counts
## @param legendText X
## @param legendFun X
## @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,
 #                   plotinorder=FALSE,
  #                  legendText=NULL,
   #                 legendFun=NULL,
	#				...){
#
 #   if(plotinorder){
  #      x@plotOrder <- order(x@data[[what]])
   # }
#
#	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,...)
#		}
#
 #       messwithlegend <- function(txt,fun,dp=2){
  #          txt <- t(gsub("]","",gsub("\\[","",gsub("\\(","",sapply(txt,function(x){unlist(strsplit(x,","))})))))
   #         txt <- round(fun(matrix(as.numeric(txt),ncol=2)),dp)
    #        txt <- apply(txt,1,function(x){paste("(",x[1],",",x[2],"]",sep="")})
     #       substr(txt[1],1,1) <- "["
      #      return(txt)
       # }
#
#		if(printlegend){
 #           if(is.null(legendText)){
  #              legendText <- lvls
   #         }
#
 #           if(!is.null(legendFun)){
  #              legendText <- messwithlegend(legendText,legendFun)
   #         }
#
#			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=legendText,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 <- OpenStreetMap::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)
#}