Related
I want to predict vegetation health using 2 remote sensing vegetation indices (VIs) for multiple tree-stands across multiple months. I previously approached this by using a for() loop to iterate through a list of multi-band rasters and calculate the two VIs for each raster (month) using a given equation. I then used raster::extract() to extract the pixels corresponding to each stand. However, I now would like to include some additional variables in my predictions of vegetation health, and am having trouble integrating them using the same method as they are simply columns in a dataframe and not rasters. I'm open to different ways to do this, I just can't think of any.
example:
#Part 1: Loading libraries and creating some sample data
library(sf)
library(raster)
library(terra)
#polygons to generate random points into
v <- vect(system.file("ex/lux.shp", package="terra"))
v <- v[c(1:12)]
v_sf <- st_as_sf(v) # Convert 'SpatVector' into 'sf' object
#5 rasters (months) with 5 bands each
r <- rast(system.file("ex/elev.tif", package="terra"))
r <- rep(r, 5) * 1:5
names(r) <- paste0("band", 1:5)
ras_list <- list(r,r,r,r,r)
#generating some points (10 forest stands)
pnts <- st_sample(v_sf, size = 10, type = "random")
pnts<- as_Spatial(pnts)
#Part 2: Loop to predict vegetation health using two VI variables
vis <- list() #empty list to store NDVI rasters
for (i in seq_along(ras_list)) {
b <- ras_list[[i]]
#vegetation health = 1.23 + (0.45 * VI1) - (0.67 * VI2)
vis[i] <- 1.23 + 0.45*((b[[4]] + b[[3]] - b[[1]]) / (b[[4]] + b[[3]])) - 0.67*(b[[1]] * b[[3]] - b[[4]])
}
#Part 3: Loop to extract pixel values for each forest stand
vi_vals <- list() #empty list to store extracted pixel values
for (i in 1:length(vis)) {
n <- raster(vis[[i]])
vi_vals[[i]] <- raster::extract(n, pnts, method = "bilinear")
}
This method works fine but as I mentioned above, I now need to repeat the same process using a new equation which incorporates variables that can't be calculated from a raster. These values are simply 3 columns in a dataframe that are identified by a stand ID.
Let's first simplify your example a bit
Example data
library(terra)
v <- vect(system.file("ex/lux.shp", package="terra"))
r <- rast(system.file("ex/elev.tif", package="terra"))
r <- rep(r, 5) * 1:5
names(r) <- paste0("b", 1:5)
ras_list <- list(r,r,r,r,r)
set.seed(1)
pnts <- spatSample(v, 10, "random")
values(pnts) = data.frame(id=10, a=5:14, b=3:12, d=6:15)
Compute VI and extract
vis <- list()
for (i in seq_along(ras_list)) {
b <- ras_list[[i]]
vis[[i]] <- 1.23 + 0.45*((b[[4]] + b[[3]] - b[[1]]) / (b[[4]] + b[[3]])) - 0.67*(b[[1]] * b[[3]] - b[[4]])
}
vis <- rast(vis)
names(vis) = paste0("set", 1:5)
vi_vals <- extract(vis, pnts, method = "bilinear")
And now you can do something with the tree parameters
out <- t(t(vi_vals[,-1])) * pnts$a + pnts$b / pnts$d
It would be more efficient to first extract the values and then apply the function
e <- list()
for (i in seq_along(ras_list)) {
x <- extract(ras_list[[i]], pnts, method="bilinear")[,-1]
e[[i]] = (1.23 + 0.45*((x$b4 + x$b3 - x$b1) / (x$b4 + x$b3)) - 0.67*(x$b1 * x$b3 - x$b4)) * pnts$a + pnts$b / pnts$d
}
e <- do.call(cbind, e)
The results are not exactly the same; I assume because of loss of decimal number precision in one or the other method.
I've seen a figure in a paper (Perales & Mas, 2007; Plant Cell) and I'm interested in making a similar graph with my data in R.
I have some circadian gene expression data and I need to represent which is the phase (the maximum peak of expression of a certain gene) of some genes. The graph I'm refering to is like a clock in which you can see at what time a gene has its maximum peak of expression.
(C) Phase plot of TOC1:LUC and CAB2:LUC expression in wild-type and TMG plants under the indicated photoperiods. Phases (phase/period × 24 h) were plotted against the strength of the rhythm expressed as relative amplitude error. The rhythm strength is graphed from 0 (center of the plot) to 0.8 (periphery of the circle), which indicates robust and very weak rhythms, respectively.
## generate data
set.seed(1);
gen <- data.frame(gene=c(rep('TOC1',3),rep('CAB2',3)), plant=c(rep(NA,3),'WT','WT','TMG'), photoperiod=c('8:16','12:12','16:8','8:16','16:8','8:16'), hourmean=c(11,13.5,15,4,6.5,6.5), hoursd=c(0.25,0.25,0.25,0.4,0.15,0.4), strengthmean=c(0.25,0.2,0.25,0.32,0.35,0.4), strengthsd=c(0.035,0.03,0.035,0.02,0.03,0.02), num=c(20,20,20,5,10,10), stringsAsFactors=F );
df <- cbind(as.data.frame(lapply(gen[,c('gene','plant','photoperiod')],rep,gen$num)),hour=rnorm(sum(gen$num),rep(gen$hourmean,gen$num),rep(gen$hoursd,gen$num)),strength=rnorm(sum(gen$num),rep(gen$strengthmean,gen$num),rep(gen$strengthsd,gen$num)));
tau <- 2*pi;
## define point specifications per group
ptspec <- data.frame(gene=c('TOC1','TOC1','TOC1','CAB2','CAB2','CAB2'), plant=c(NA,NA,NA,'WT','WT','TMG'), photoperiod=c('8:16','12:12','16:8','8:16','16:8','8:16'), pch=c(22,22,22,21,21,24), col=c('black','red','blue','black','blue','red'), bg=c('white','white','white','black','blue','white'), cex=1.8, lwd=3, stringsAsFactors=F );
## define virtual plot margins and overall plot region
A <- 24;
R <- 0.8;
imar <- 0.25;
bmar <- 0.4;
xlim <- c(-R,R)*(1+imar);
ylim <- c(-R*(1+imar+bmar),R*(1+imar));
## define angular and radial tick parameters
atick <- seq(0,A,3)[-A/3-1];
rtick <- seq(0,R,0.2);
atickLen <- R/50;
atickLabelDist <- atickLen*6;
## plotting helper functions
circles <- function(x,y,r,n=1000,col,lty,lwd,...) {
comb <- cbind(x,y,r);
angles <- tau*0:n/n;
if (!missing(col) && !is.null(col)) col <- rep(col,len=nrow(comb));
if (!missing(lty) && !is.null(lty)) lty <- rep(lty,len=nrow(comb));
if (!missing(lwd) && !is.null(lwd)) lwd <- rep(lwd,len=nrow(comb));
for (i in 1:nrow(comb)) {
args <- list(
comb[i,'x']+comb[i,'r']*cos(angles),
comb[i,'y']+comb[i,'r']*sin(angles)
);
if (!missing(col)) if (is.null(col)) args['col'] <- list(NULL) else args$col <- col[i];
if (!missing(lty)) if (is.null(lty)) args['lty'] <- list(NULL) else args$lty <- lty[i];
if (!missing(lwd)) if (is.null(lwd)) args['lwd'] <- list(NULL) else args$lwd <- lwd[i];
do.call(lines, c(args,...) );
}; ## end for
}; ## end circles()
radials <- function(x,y,a,r,...) {
comb <- cbind(x,y,a,r);
segments(comb[,'x'],comb[,'y'],comb[,'x']+comb[,'r']*cos(comb[,'a']),comb[,'y']+comb[,'r']*sin(comb[,'a']),...);
}; ## end radials()
## main plot
par(mar=c(1,1,1,1)+0.1,xaxs='i',yaxs='i');
plot(NA,xlim=xlim,ylim=ylim,axes=F,xlab='',ylab='');
circles(0,0,rtick,col='#aaaaaa',lty=3);
circles(0,0,R,lwd=2);
radials(0,0,tau*atick/A,R,col='#aaaaaa');
radials(R*cos(tau*atick/A),R*sin(tau*atick/A),tau*atick/A,atickLen,lwd=2);
text((R+atickLabelDist)*cos(tau*atick/A),(R+atickLabelDist)*sin(tau*atick/A),(A-atick+6)%%A,family='sans',font=2,cex=2);
with(merge(df,ptspec)[nrow(df):1,],points(strength*cos(tau*(A-hour+6)%%A/A),strength*sin(tau*(A-hour+6)%%A/A),pch=pch,col=col,bg=bg,cex=cex,lwd=lwd));
## common legend precomputations
legendTopSpace <- R/10;
legendBotSpace <- R/10;
legendDivCut <- R/20;
legendTop <- -R-legendTopSpace;
legendBot <- ylim[1]+legendBotSpace;
legendDivTop <- legendTop-legendDivCut;
legendDivBot <- legendBot+legendDivCut;
legendDivLeftSpace <- R/20;
legendDivRightSpace <- R/10;
legendPtSpace <- R/15;
## legend 1
legend1Gene <- 'TOC1';
legend1PtSpec <- subset(ptspec,gene==legend1Gene);
legend1PtSpec <- legend1PtSpec[nrow(legend1PtSpec):1,];
legend1DivX <- -R+2/5*R;
segments(legend1DivX,legendDivBot,legend1DivX,legendDivTop,lwd=3);
text(legend1DivX-legendDivLeftSpace,(legendTop+legendBot)/2,legend1Gene,c(1,NA),family='sans',font=2,cex=1.5);
legend1PtX <- legend1DivX+legendDivRightSpace;
legend1PtYSpace <- (legendTop-legendBot)/(nrow(legend1PtSpec)+1);
legend1PtY <- seq(legendBot+legend1PtYSpace,legendTop-legend1PtYSpace,len=nrow(legend1PtSpec));
with(legend1PtSpec,points(rep(legend1PtX,nrow(legend1PtSpec)),legend1PtY,pch=pch,col=col,bg=bg,cex=cex,lwd=lwd));
legend1LabelX <- legend1PtX+legendPtSpace;
text(rep(legend1LabelX,nrow(legend1PtSpec)),legend1PtY,with(legend1PtSpec,ifelse(is.na(plant),photoperiod,paste(plant,photoperiod))),c(0,NA),family='sans',font=2,cex=1.5);
## legend 2
legend2Gene <- 'CAB2';
legend2PtSpec <- subset(ptspec,gene==legend2Gene);
legend2PtSpec <- legend2PtSpec[nrow(legend2PtSpec):1,];
legend2DivX <- 2/5*R;
segments(legend2DivX,legendDivBot,legend2DivX,legendDivTop,lwd=3);
text(legend2DivX-legendDivLeftSpace,(legendTop+legendBot)/2,legend2Gene,c(1,NA),family='sans',font=2,cex=1.5);
legend2PtX <- legend2DivX+legendDivRightSpace;
legend2PtYSpace <- (legendTop-legendBot)/(nrow(legend2PtSpec)+1);
legend2PtY <- seq(legendBot+legend2PtYSpace,legendTop-legend2PtYSpace,len=nrow(legend2PtSpec));
with(legend2PtSpec,points(rep(legend2PtX,nrow(legend2PtSpec)),legend2PtY,pch=pch,col=col,bg=bg,cex=cex,lwd=lwd));
legend2LabelX <- legend2PtX+legendPtSpace;
text(rep(legend2LabelX,nrow(legend2PtSpec)),legend2PtY,with(legend2PtSpec,ifelse(is.na(plant),photoperiod,paste(plant,photoperiod))),c(0,NA),family='sans',font=2,cex=1.5);
I'm trying to use parallel::mclapply to speed up the calculation of the following code:
library(raster)
library(HistogramTools)#for AddHistogram
#Create a first h here for the first band... omitted for brevity
readNhist <- function(n,mconst) {
l <- raster(filename[i], varname=var[i], band=n, na.rm=T)
gain(l) <- mconst
h <<- AddHistograms(h, hist(l, plot=F, breaks=histbreaks,right=FALSE))
}
lapply( 1:10000, readNhist, mconst=1, mc.cores=7 )
#Then do stuff with the h histogram...
When performing the code above, all is fine. If using mclapply (below), the result is miles away from what I want to obtain: the histograms are all wrong.
library(raster)
library(HistogramTools)#for AddHistogram
library(parallel)
#Create a first h here for the first band... omitted for brevity
readNhist <- function(n,mconst) {
l <- raster(filename[i], varname=var[i], band=n, na.rm=T)
gain(l) <- mconst
h <<- AddHistograms(h, hist(l, plot=F, breaks=histbreaks,right=FALSE))
}
mclapply( 2:10000, readNhist, mconst=1 )
#Then do stuff with the h histogram...
I feel like there's something vital I'm missing with the application of parallel computation to this function.
The problem is the <<- which is bad practice in general as far as I can gather.
The function can be rearranged thusly:
readNhist <- function(n,mconst) {
l <- raster(filename, varname=var, band=n, na.rm=T)
gain(l) <- mconst
hist <- hist(l, plot=F, breaks=histbreaks,right=FALSE)
return(hist)
}
And called like this:
hists <- mclapply( 2:nbands, readNhist, mconst=gain, mc.cores=ncores )
ch <- AddHistograms(x=hists)
h <- AddHistograms(h, ch)
rm(ch, hists)
This is pretty fast even with a huge number of layers (and thus histograms).
I want to colour the area under a curve. The area with y > 0 should be red, the area with y < 0 should be green.
x <- c(1:4)
y <- c(0,1,-1,2,rep(0,4))
plot(y[1:4],type="l")
abline(h=0)
Using ifelse() does not work:
polygon(c(x,rev(x)),y,col=ifelse(y>0,"red","green"))
What I achieved so far is the following:
polygon(c(x,rev(x)),y,col="green")
polygon(c(x,rev(x)),ifelse(y>0,y,0),col="red")
But then the red area is too large. Do you have any ideas how to get the desired result?
If you want two different colors, you need two different polygons. You can either call polygon multiple times, or you can add NA values in your x and y vectors to indicate a new polygon. R will not automatically calculate the intersection for you. You must do that yourself. Here's how you could draw that with different colors.
x <- c(1,2,2.5,NA,2.5,3,4)
y <- c(0,1,0,NA,0,-1,0)
#calculate color based on most extreme y value
g <- cumsum(is.na(x))
gc <- ifelse(tapply(y, g,
function(x) x[which.max(abs(x))])>0,
"red","green")
plot(c(1, 4),c(-1,1), type = "n")
polygon(x, y, col = gc)
abline(h=0)
In the more general case, it might not be as easy to split a polygon into different regions. There seems to be some support for this type of operation in GIS packages, where this type of thing is more common. However, I've put together a somewhat general case that may work for simple polygons.
First, I define a closure that will define a cutting line. The function will take a slope and y-intercept for a line and will return the functions we need to cut a polygon.
getSplitLine <- function(m=1, b=0) {
force(m); force(b)
classify <- function(x,y) {
y >= m*x + b
}
intercepts <- function(x,y, class=classify(x,y)) {
w <- which(diff(class)!=0)
m2 <- (y[w+1]-y[w])/(x[w+1]-x[w])
b2 <- y[w] - m2*x[w]
ix <- (b2-b)/(m-m2)
iy <- ix*m + b
data.frame(x=ix,y=iy,idx=w+.5, dir=((rank(ix, ties="first")+1) %/% 2) %% 2 +1)
}
plot <- function(...) {
abline(b,m,...)
}
list(
intercepts=intercepts,
classify=classify,
plot=plot
)
}
Now we will define a function to actually split a polygon using the splitter we've just defined.
splitPolygon <- function(x, y, splitter) {
addnullrow <- function(x) if (!all(is.na(x[nrow(x),]))) rbind(x, NA) else x
rollup <- function(x,i=1) rbind(x[(i+1):nrow(x),], x[1:i,])
idx <- cumsum(is.na(x) | is.na(y))
polys <- split(data.frame(x=x,y=y)[!is.na(x),], idx[!is.na(x)])
r <- lapply(polys, function(P) {
x <- P$x; y<-P$y
side <- splitter$classify(x, y)
if(side[1] != side[length(side)]) {
ints <- splitter$intercepts(c(x,x[1]), c(y, y[1]), c(side, side[1]))
} else {
ints <- splitter$intercepts(x, y, side)
}
sideps <- lapply(unique(side), function(ss) {
pts <- data.frame(x=x[side==ss], y=y[side==ss],
idx=seq_along(x)[side==ss], dir=0)
mm <- rbind(pts, ints)
mm <- mm[order(mm$idx), ]
br <- cumsum(mm$dir!=0 & c(0,head(mm$dir,-1))!=0 &
c(0,diff(mm$idx))>1)
if (length(unique(br))>1) {
mm<-rollup(mm, sum(br==br[1]))
}
br <- cumsum(c(FALSE,abs(diff(mm$dir*mm$dir))==3))
do.call(rbind, lapply(split(mm, br), addnullrow))
})
pss<-rep(unique(side), sapply(sideps, nrow))
ps<-do.call(rbind, lapply(sideps, addnullrow))[,c("x","y")]
attr(ps, "side")<-pss
ps
})
pss<-unname(unlist(lapply(r, attr, "side")))
src <- rep(seq_along(r), sapply(r, nrow))
r <- do.call(rbind, r)
attr(r, "source")<-src
attr(r, "side")<-pss
r
}
The input is just the values of x and y as you would pass to polygon along with the cutter. It will return a data.frame with x and y values that can be used with polygon.
For example
x <- c(1,2,2.5,NA,2.5,3,4)
y <- c(1,-2,2,NA,-1,2,-2)
sl<-getSplitLine(0,0)
plot(range(x, na.rm=T),range(y, na.rm=T), type = "n")
p <- splitPolygon(x,y,sl)
g <- cumsum(c(F, is.na(head(p$y,-1))))
gc <- ifelse(attr(p,"side")[is.na(p$y)],
"red","green")
polygon(p, col=gc)
sl$plot(lty=2, col="grey")
This should work for simple concave polygons as well with sloped lines. Here's another example
x <- c(1,2,3,4,5,4,3,2)
y <- c(-2,2,1,2,-2,.5,-.5,.5)
sl<-getSplitLine(.5,-1.25)
plot(range(x, na.rm=T),range(y, na.rm=T), type = "n")
p <- splitPolygon(x,y,sl)
g <- cumsum(c(F, is.na(head(p$y,-1))))
gc <- ifelse(attr(p,"side")[is.na(p$y)],
"red","green")
polygon(p, col=gc)
sl$plot(lty=2, col="grey")
Right now things can get a bit messy when the the vertex of the polygon falls directly on the splitting line. I may try to correct that in the future.
A faster, but not very accurate solution is to split data frame to list according to grouping variable (e.g. above=red and below=blue). This is a pretty nice workaround for rather big (I would say > 100 elements) datasets. For smaller chunks some discontinuity may be visible:
x <- 1:100
y1 <- sin(1:100/10)*0.8
y2 <- sin(1:100/10)*1.2
plot(x, y2, type='l')
lines(x, y1, col='red')
df <- data.frame(x=x, y1=y1, y2=y2)
df$pos_neg <- ifelse(df$y2-df$y1>0,1,-1) # above (1) or below (-1) average
# create the number for chunks to be split into lists:
df$chunk <- c(1,cumsum(abs(diff(df$pos_neg)))/2+1) # first element needs to be added`
df$colors <- ifelse(df$pos_neg>0, "red","blue") # colors to be used for filling the polygons
# create lists to be plotted:
l <- split(df, df$chunk) # we should get 4 sub-lists
lapply(l, function(x) polygon(c(x$x,rev(x$x)),c(x$y2,rev(x$y1)),col=x$colors))
As I said, for smaller dataset some discontinuity may be visible if sharp changes occur between positive and negative areas, but if horizontal line distinguishes between those two, or more elements are plotted then this effect is neglected:
Does anyone know of a way to turn the output of contourLines polygons in order to plot as filled contours, as with filled.contours. Is there an order to how the polygons must then be plotted in order to see all available levels? Here is an example snippet of code that doesn't work:
#typical plot
filled.contour(volcano, color.palette = terrain.colors)
#try
cont <- contourLines(volcano)
fun <- function(x) x$level
LEVS <- sort(unique(unlist(lapply(cont, fun))))
COLS <- terrain.colors(length(LEVS))
contour(volcano)
for(i in seq(cont)){
COLNUM <- match(cont[[i]]$level, LEVS)
polygon(cont[[i]], col=COLS[COLNUM], border="NA")
}
contour(volcano, add=TRUE)
A solution that uses the raster package (which calls rgeos and sp). The output is a SpatialPolygonsDataFrame that will cover every value in your grid:
library('raster')
rr <- raster(t(volcano))
rc <- cut(rr, breaks= 10)
pols <- rasterToPolygons(rc, dissolve=T)
spplot(pols)
Here's a discussion that will show you how to simplify ('prettify') the resulting polygons.
Thanks to some inspiration from this site, I worked up a function to convert contour lines to filled contours. It's set-up to process a raster object and return a SpatialPolygonsDataFrame.
raster2contourPolys <- function(r, levels = NULL) {
## set-up levels
levels <- sort(levels)
plevels <- c(min(values(r), na.rm=TRUE), levels, max(values(r), na.rm=TRUE)) # pad with raster range
llevels <- paste(plevels[-length(plevels)], plevels[-1], sep=" - ")
llevels[1] <- paste("<", min(levels))
llevels[length(llevels)] <- paste(">", max(levels))
## convert raster object to matrix so it can be fed into contourLines
xmin <- extent(r)#xmin
xmax <- extent(r)#xmax
ymin <- extent(r)#ymin
ymax <- extent(r)#ymax
rx <- seq(xmin, xmax, length.out=ncol(r))
ry <- seq(ymin, ymax, length.out=nrow(r))
rz <- t(as.matrix(r))
rz <- rz[,ncol(rz):1] # reshape
## get contour lines and convert to SpatialLinesDataFrame
cat("Converting to contour lines...\n")
cl <- contourLines(rx,ry,rz,levels=levels)
cl <- ContourLines2SLDF(cl)
## extract coordinates to generate overall boundary polygon
xy <- coordinates(r)[which(!is.na(values(r))),]
i <- chull(xy)
b <- xy[c(i,i[1]),]
b <- SpatialPolygons(list(Polygons(list(Polygon(b, hole = FALSE)), "1")))
## add buffer around lines and cut boundary polygon
cat("Converting contour lines to polygons...\n")
bcl <- gBuffer(cl, width = 0.0001) # add small buffer so it cuts bounding poly
cp <- gDifference(b, bcl)
## restructure and make polygon number the ID
polys <- list()
for(j in seq_along(cp#polygons[[1]]#Polygons)) {
polys[[j]] <- Polygons(list(cp#polygons[[1]]#Polygons[[j]]),j)
}
cp <- SpatialPolygons(polys)
cp <- SpatialPolygonsDataFrame(cp, data.frame(id=seq_along(cp)))
## cut the raster by levels
rc <- cut(r, breaks=plevels)
## loop through each polygon, create internal buffer, select points and define overlap with raster
cat("Adding attributes to polygons...\n")
l <- character(length(cp))
for(j in seq_along(cp)) {
p <- cp[cp$id==j,]
bp <- gBuffer(p, width = -max(res(r))) # use a negative buffer to obtain internal points
if(!is.null(bp)) {
xy <- SpatialPoints(coordinates(bp#polygons[[1]]#Polygons[[1]]))[1]
l[j] <- llevels[extract(rc,xy)]
}
else {
xy <- coordinates(gCentroid(p)) # buffer will not be calculated for smaller polygons, so grab centroid
l[j] <- llevels[extract(rc,xy)]
}
}
## assign level to each polygon
cp$level <- factor(l, levels=llevels)
cp$min <- plevels[-length(plevels)][cp$level]
cp$max <- plevels[-1][cp$level]
cp <- cp[!is.na(cp$level),] # discard small polygons that did not capture a raster point
df <- unique(cp#data[,c("level","min","max")]) # to be used after holes are defined
df <- df[order(df$min),]
row.names(df) <- df$level
llevels <- df$level
## define depressions in higher levels (ie holes)
cat("Defining holes...\n")
spolys <- list()
p <- cp[cp$level==llevels[1],] # add deepest layer
p <- gUnaryUnion(p)
spolys[[1]] <- Polygons(p#polygons[[1]]#Polygons, ID=llevels[1])
for(i in seq(length(llevels)-1)) {
p1 <- cp[cp$level==llevels[i+1],] # upper layer
p2 <- cp[cp$level==llevels[i],] # lower layer
x <- numeric(length(p2)) # grab one point from each of the deeper polygons
y <- numeric(length(p2))
id <- numeric(length(p2))
for(j in seq_along(p2)) {
xy <- coordinates(p2#polygons[[j]]#Polygons[[1]])[1,]
x[j] <- xy[1]; y[j] <- xy[2]
id[j] <- as.numeric(p2#polygons[[j]]#ID)
}
xy <- SpatialPointsDataFrame(cbind(x,y), data.frame(id=id))
holes <- over(xy, p1)$id
holes <- xy$id[which(!is.na(holes))]
if(length(holes)>0) {
p2 <- p2[p2$id %in% holes,] # keep the polygons over the shallower polygon
p1 <- gUnaryUnion(p1) # simplify each group of polygons
p2 <- gUnaryUnion(p2)
p <- gDifference(p1, p2) # cut holes in p1
} else { p <- gUnaryUnion(p1) }
spolys[[i+1]] <- Polygons(p#polygons[[1]]#Polygons, ID=llevels[i+1]) # add level
}
cp <- SpatialPolygons(spolys, pO=seq_along(llevels), proj4string=CRS(proj4string(r))) # compile into final object
cp <- SpatialPolygonsDataFrame(cp, df)
cat("Done!")
cp
}
It probably holds several inefficiencies, but it has worked well in the tests I've conducted using bathymetry data. Here's an example using the volcano data:
r <- raster(t(volcano))
l <- seq(100,200,by=10)
cp <- raster2contourPolys(r, levels=l)
cols <- terrain.colors(length(cp))
plot(cp, col=cols, border=cols, axes=TRUE, xaxs="i", yaxs="i")
contour(r, levels=l, add=TRUE)
box()
Building on the excellent work of Paul Regular, here is a version that should ensure exclusive polygons (i.e. no overlapping).
I've added a new argument fd for fairy dust to address an issue I discovered working with UTM-type coordinates. Basically as I understand the algorithm works by sampling lateral points from the contour lines to determine which side is inside the polygon. The distance of the sample point from the line can create problems if it ends up in e.g. behind another contour. So if your resulting polygons looks wrong try setting fd to values 10^±n until it looks very wrong or about right..
raster2contourPolys <- function(r, levels = NULL, fd = 1) {
## set-up levels
levels <- sort(levels)
plevels <- c(min(values(r)-1, na.rm=TRUE), levels, max(values(r)+1, na.rm=TRUE)) # pad with raster range
llevels <- paste(plevels[-length(plevels)], plevels[-1], sep=" - ")
llevels[1] <- paste("<", min(levels))
llevels[length(llevels)] <- paste(">", max(levels))
## convert raster object to matrix so it can be fed into contourLines
xmin <- extent(r)#xmin
xmax <- extent(r)#xmax
ymin <- extent(r)#ymin
ymax <- extent(r)#ymax
rx <- seq(xmin, xmax, length.out=ncol(r))
ry <- seq(ymin, ymax, length.out=nrow(r))
rz <- t(as.matrix(r))
rz <- rz[,ncol(rz):1] # reshape
## get contour lines and convert to SpatialLinesDataFrame
cat("Converting to contour lines...\n")
cl0 <- contourLines(rx, ry, rz, levels = levels)
cl <- ContourLines2SLDF(cl0)
## extract coordinates to generate overall boundary polygon
xy <- coordinates(r)[which(!is.na(values(r))),]
i <- chull(xy)
b <- xy[c(i,i[1]),]
b <- SpatialPolygons(list(Polygons(list(Polygon(b, hole = FALSE)), "1")))
## add buffer around lines and cut boundary polygon
cat("Converting contour lines to polygons...\n")
bcl <- gBuffer(cl, width = fd*diff(bbox(r)[1,])/3600000) # add small buffer so it cuts bounding poly
cp <- gDifference(b, bcl)
## restructure and make polygon number the ID
polys <- list()
for(j in seq_along(cp#polygons[[1]]#Polygons)) {
polys[[j]] <- Polygons(list(cp#polygons[[1]]#Polygons[[j]]),j)
}
cp <- SpatialPolygons(polys)
cp <- SpatialPolygonsDataFrame(cp, data.frame(id=seq_along(cp)))
# group by elev (replicate ids)
# ids = sapply(slot(cl, "lines"), slot, "ID")
# lens = sapply(1:length(cl), function(i) length(cl[i,]#lines[[1]]#Lines))
## cut the raster by levels
rc <- cut(r, breaks=plevels)
## loop through each polygon, create internal buffer, select points and define overlap with raster
cat("Adding attributes to polygons...\n")
l <- character(length(cp))
for(j in seq_along(cp)) {
p <- cp[cp$id==j,]
bp <- gBuffer(p, width = -max(res(r))) # use a negative buffer to obtain internal points
if(!is.null(bp)) {
xy <- SpatialPoints(coordinates(bp#polygons[[1]]#Polygons[[1]]))[1]
l[j] <- llevels[raster::extract(rc,xy)]
}
else {
xy <- coordinates(gCentroid(p)) # buffer will not be calculated for smaller polygons, so grab centroid
l[j] <- llevels[raster::extract(rc,xy)]
}
}
## assign level to each polygon
cp$level <- factor(l, levels=llevels)
cp$min <- plevels[-length(plevels)][cp$level]
cp$max <- plevels[-1][cp$level]
cp <- cp[!is.na(cp$level),] # discard small polygons that did not capture a raster point
df <- unique(cp#data[,c("level","min","max")]) # to be used after holes are defined
df <- df[order(df$min),]
row.names(df) <- df$level
llevels <- df$level
## define depressions in higher levels (ie holes)
cat("Defining holes...\n")
spolys <- list()
p <- cp[cp$level==llevels[1],] # add deepest layer
p <- gUnaryUnion(p)
spolys[[1]] <- Polygons(p#polygons[[1]]#Polygons, ID=llevels[1])
for(i in seq(length(llevels)-1)) {
p1 <- cp[cp$level==llevels[i+1],] # upper layer
p2 <- cp[cp$level==llevels[i],] # lower layer
x <- numeric(length(p2)) # grab one point from each of the deeper polygons
y <- numeric(length(p2))
id <- numeric(length(p2))
for(j in seq_along(p2)) {
xy <- coordinates(p2#polygons[[j]]#Polygons[[1]])[1,]
x[j] <- xy[1]; y[j] <- xy[2]
id[j] <- as.numeric(p2#polygons[[j]]#ID)
}
xy <- SpatialPointsDataFrame(cbind(x,y), data.frame(id=id))
holes <- over(xy, p1)$id
holes <- xy$id[which(!is.na(holes))]
if(length(holes)>0) {
p2 <- p2[p2$id %in% holes,] # keep the polygons over the shallower polygon
p1 <- gUnaryUnion(p1) # simplify each group of polygons
p2 <- gUnaryUnion(p2)
p <- gDifference(p1, p2) # cut holes in p1
} else { p <- gUnaryUnion(p1) }
spolys[[i+1]] <- Polygons(p#polygons[[1]]#Polygons, ID=llevels[i+1]) # add level
}
cp <- SpatialPolygons(spolys, pO=seq_along(llevels), proj4string=CRS(proj4string(r))) # compile into final object
## make polygons exclusive (i.e. no overlapping)
cpx = gDifference(cp[1,], cp[2,], id=cp[1,]#polygons[[1]]#ID)
for(i in 2:(length(cp)-1)) cpx = spRbind(cpx, gDifference(cp[i,], cp[i+1,], id=cp[i,]#polygons[[1]]#ID))
cp = spRbind(cpx, cp[length(cp),])
## it's a wrap
cp <- SpatialPolygonsDataFrame(cp, df)
cat("Done!")
cp
}