This is how I plot multiple raster
library(raster)
x <- raster::getData('worldclim', var='tmin', res = 10)
var.list <- c("tmin1","tmin2","tmin3","tmin4")
ras.stack <- stack()
for(i in var.list){
stack.list <- stack(stack.list, x[[paste0(i)]])
}
spplot(stack.list)
I want to do the same for 4 shape files which have a common attribute
called "mean.value"
fra <- raster::getData('GADM',country = 'FRA', level = 2)
shp.stack <- stack()
for(i in 1:4){
mean.value <- data.frame(NAME_2 = fra#data$NAME_2, sample(1:200, 96))
my.shp <- merge(fra, mean.value, by = 'NAME_2')
shp.stack <- stack(shp.stack, my.shp)
}
Error in sapply(x, fromDisk) & sapply(x, inMemory) : operations
are possible only for numeric, logical or complex types
How can I fix it?
You have to transform the SpatialPolygonsDataFrame to a raster object first, to be able to stack it. You could also transform to SpatialGrid*, SpatialPixels* - objects based on the manual of raster::stack.
So your second code would become something like this:
library(raster)
fra <- raster::getData('GADM',country = 'FRA', level = 2)
shp.stack <- stack()
for(i in 1:4){
mean.value <- data.frame(NAME_2 = fra#data$NAME_2, sample(1:200, 96))
my.shp <- raster::merge(fra, mean.value, by = 'NAME_2')
r <- raster(ncol=180, nrow=180)
extent(r) <- extent(my.shp)
rp <- rasterize(x = my.shp, y = r)
shp.stack <- raster::stack(shp.stack, rp)
}
plot(shp.stack)
Related
library(raster)
library(rnaturalearth)
library(terra)
r <- raster::getData('CMIP5', var='tmin', res=10, rcp=45, model='HE', year=70)
r <- r[[1]]
shp <- rnaturalearth::ne_countries()
newcrs <- "+proj=robin +datum=WGS84"
r <- rast(r)
shp <- vect(shp)
r_pr <- terra::project(r, newcrs)
shp_pr <- terra::project(shp, newcrs)
For every country in shp_pr, I want to normalise the underlying raster
on a scale of 0-1. This means dividing a cell by the sum of all the cells within a country boundary and repeating it for all the countries. I am doing this as follows:
country_vec <- shp$sovereignt
temp_ls <- list()
for(c in seq_along(country_vec)){
country_ref <- country_vec[c]
if(country_ref == "Antarctica") { next }
shp_ct <- shp[shp$sovereignt == country_ref]
r_country <- terra::crop(r, shp_ct) # crops to the extent of boundary
r_country <- terra::extract(r_country, shp_ct, xy=T)
r_country$score_norm <- r_country$he45tn701/sum(na.omit(r_country$he45tn701))
r_country_norm_rast <- rasterFromXYZ(r_country[ , c("x","y","score_norm")])
temp_ls[[c]] <- r_country_norm_rast
rm(shp_ct, r_country, r_country_norm_rast)
}
m <- do.call(merge, temp_ls)
I wondered if this is the most efficient/right way to do this i.e. without any for loop and anyone has any suggestions?
Somewhat updated and simplified example data (there is no need for projection the data)
library(terra)
library(geodata)
r <- geodata::cmip6_world("HadGEM3-GC31-LL", "585", "2061-2080", "tmin", 10, ".")[[1]]
v <- world(path=".")
v$ID <- 1:nrow(v)
Solution
z <- rasterize(v, r, "ID", touches=TRUE)
zmin <- zonal(r, z, min, na.rm=TRUE, as.raster=TRUE)
zmax <- zonal(r, z, max, na.rm=TRUE, as.raster=TRUE)
x <- (r - zmin) / (zmax - zmin)
Note that the above normalizes the cell values for each country between 0 and 1.
To transform the data such that the values add up to 1 (by country), you can do:
z <- rasterize(v, r, "ID", touches=TRUE)
zsum <- zonal(r, z, sum, na.rm=TRUE, as.raster=TRUE)
x <- r / zsum
So I have a large data set that I have imported and split up. I've made sure to attach everything and tried to run a code to determine the number of breakpoints using AIC.
rm(list=ls())
library(Matching)
library(segmented)
dinosaurs=read.csv("C:/Users/user/Desktop/NEW PLOTS FOR DINOS/centrum_input_fin.csv")
attach(dinosaurs)
names(dinosaurs)
dino_names <- names(dinosaurs)
#NEED TO EXPORT FILES (EXPORT THE ALL_DATA_PLUS_SORTED OUT)
all_data_plus_sorted<-NULL
for(j in 1:length(dino_names))
{
with_gaps<-eval(parse(text = dino_names[j]))
gaps <- which(is.na(with_gaps))
non_gaps <-which(1:length(with_gaps) %in%gaps==FALSE)
sorted_without_gaps <- sort(with_gaps[!is.na(with_gaps)],decreasing=TRUE)
ordered_with_gaps<-rep(NA,length(with_gaps))
for(k in 1:length(non_gaps))
{
ordered_with_gaps[non_gaps[k]] <- sorted_without_gaps[k]
}
to_export<-cbind(with_gaps,ordered_with_gaps)
colnames(to_export)<-c(paste(dino_names[j],"_actual_with_gaps",sep=""),paste(dino_names[j],"_ordered_with_gaps",sep=""))
all_data_plus_sorted<- cbind(all_data_plus_sorted,to_export)
}
all_data_plus_sorted
attach(as.data.frame(all_data_plus_sorted))
print(dinosaurs)
detach(as.data.frame(all_data_plus_sorted))
detach(dinosaurs)
#split species
Dyoplosaurus_acutosquameus_ROM734 <- Dyoplosaurus_acutosquameus_ROM734[!is.na(Dyoplosaurus_acutosquameus_ROM734)]
Staurikosaurus_pricei <- Staurikosaurus_pricei[!is.na(Staurikosaurus_pricei)]
Opistocoelocaudia_skarzynskii <- Opistocoelocaudia_skarzynskii[!is.na(Opistocoelocaudia_skarzynskii)]
Stegosaurus_stenops._NHMUKPVR36730 <- Stegosaurus_stenops._NHMUKPVR36730[!is.na(Stegosaurus_stenops._NHMUKPVR36730)]
Giraffatitan_brancai <- Giraffatitan_brancai[!is.na(Giraffatitan_brancai)]
Camptosaurus <- Camptosaurus[!is.na(Camptosaurus)]
Camptosaurus_prestwichii <- Camptosaurus_prestwichii[!is.na(Camptosaurus_prestwichii)]
A_greppini <- A_greppini[!is.na(A_greppini)]
Astrophocaudia_slaughteri_SMU61732 <- Astrophocaudia_slaughteri_SMU61732[!is.na(Astrophocaudia_slaughteri_SMU61732)]
Tastavinsaurus_sanzi_gen_MPZ999 <- Tastavinsaurus_sanzi_gen_MPZ999[!is.na(Tastavinsaurus_sanzi_gen_MPZ999)]
MOZ_Pv1221 <- MOZ_Pv1221[!is.na(MOZ_Pv1221)]
Mamenchisaurus <- Mamenchisaurus[!is.na(Mamenchisaurus)]
Bromtosaurus_CMNo3018 <- Bromtosaurus_CMNo3018[!is.na(Bromtosaurus_CMNo3018)]
Lufengosaurus_Hueni <- Lufengosaurus_Hueni[!is.na(Lufengosaurus_Hueni)]
Mamenchisaurus_hochuanensi <- Mamenchisaurus_hochuanensi[!is.na(Mamenchisaurus_hochuanensi)]
Spinosaurus_FSACKK11888 <- Spinosaurus_FSACKK11888[!is.na(Spinosaurus_FSACKK11888)]
Buitreraptor_MPCNPV370 <- Buitreraptor_MPCNPV370[!is.na(Buitreraptor_MPCNPV370)]
Buitreraptor_MPCA245 <- Buitreraptor_MPCA245[!is.na(Buitreraptor_MPCA245)]
Huabeisaurus_allocotus_HBV20001 <- Huabeisaurus_allocotus_HBV20001[!is.na(Huabeisaurus_allocotus_HBV20001)]
Tethyshadros_insularis_SC57021 <- Tethyshadros_insularis_SC57021[!is.na(Tethyshadros_insularis_SC57021)]
Compsognathus_longipes_CNJ79 <- Compsognathus_longipes_CNJ79[!is.na(Compsognathus_longipes_CNJ79)]
Archaeopteryx12 <- Archaeopteryx12[!is.na(Archaeopteryx12)]
Sinosauropteryx_NIGP127586 <- Sinosauropteryx_NIGP127586[!is.na(Sinosauropteryx_NIGP127586)]
Sinosauropteryx_NIGP_127587 <- Sinosauropteryx_NIGP_127587[!is.na(Sinosauropteryx_NIGP_127587)]
Tetonosaurus_tilletti_AMNH3040 <- Tetonosaurus_tilletti_AMNH3040[!is.na(Tetonosaurus_tilletti_AMNH3040)]
Bambiraptor_feinbergi_FIP001 <- Bambiraptor_feinbergi_FIP001[!is.na(Bambiraptor_feinbergi_FIP001)]
Seimosaurus.halli_NMMNH3690 <- Seimosaurus.halli_NMMNH3690[!is.na(Seimosaurus.halli_NMMNH3690)]
Diluvicursor_pickeringi_NMVP221080 <- Diluvicursor_pickeringi_NMVP221080[!is.na(Diluvicursor_pickeringi_NMVP221080)]
Zhejiungosuurus_lishuiensis_ZMNHM8718 <- Zhejiungosuurus_lishuiensis_ZMNHM8718[!is.na(Zhejiungosuurus_lishuiensis_ZMNHM8718)]
Tianyulong_confuciusi_STMN.263 <- Tianyulong_confuciusi_STMN.263[!is.na(Tianyulong_confuciusi_STMN.263)]
Lusotitan_atalaiensis <- Lusotitan_atalaiensis[!is.na(Lusotitan_atalaiensis)]
Nemegtonykus_citus_MPCD100203 <- Nemegtonykus_citus_MPCD100203[!is.na(Nemegtonykus_citus_MPCD100203)]
Elaphrosaurus_bambergi_MBR4960 <- Elaphrosaurus_bambergi_MBR4960[!is.na(Elaphrosaurus_bambergi_MBR4960)]
Nomingia_gobiensis_GIN100119 <- Nomingia_gobiensis_GIN100119[!is.na(Nomingia_gobiensis_GIN100119)]
Nomingia_gobiensis_MPCD100119 <- Nomingia_gobiensis_MPCD100119[!is.na(Nomingia_gobiensis_MPCD100119)]
Chirostenotes_pergracilis <- Chirostenotes_pergracilis[!is.na(Chirostenotes_pergracilis)]
Seismosaurus_hallorum_NMMNHP3690 <- Seismosaurus_hallorum_NMMNHP3690[!is.na(Seismosaurus_hallorum_NMMNHP3690)]
Heterodontosaurus_tucki_SAMPKK1332 <- Heterodontosaurus_tucki_SAMPKK1332[!is.na(Heterodontosaurus_tucki_SAMPKK1332)]
Jianianhualong_tengi_DLXH1218 <- Jianianhualong_tengi_DLXH1218[!is.na(Jianianhualong_tengi_DLXH1218)]
Yinlong_downsi_IVPPV18685 <- Yinlong_downsi_IVPPV18685[!is.na(Yinlong_downsi_IVPPV18685)]
Neimongosaurus_yangi_LHV0001 <- Neimongosaurus_yangi_LHV0001[!is.na(Neimongosaurus_yangi_LHV0001)]
Magnapaulia_laticaudus_LACM17715 <- Magnapaulia_laticaudus_LACM17715[!is.na(Magnapaulia_laticaudus_LACM17715)]
Ouranosaurus_nigeriensis <- Ouranosaurus_nigeriensis[!is.na(Ouranosaurus_nigeriensis)]
Dreadnoughtus_schrani_MPMPV1156 <- Dreadnoughtus_schrani_MPMPV1156[!is.na(Dreadnoughtus_schrani_MPMPV1156)]
Pectodens_zhenyuensis_IVPPV18578 <- Pectodens_zhenyuensis_IVPPV18578[!is.na(Pectodens_zhenyuensis_IVPPV18578)]
Dilophosaurus_wetherilli <- Dilophosaurus_wetherilli[!is.na(Dilophosaurus_wetherilli)]
Gobihadros_mongoliensis_MPCD100746 <- Gobihadros_mongoliensis_MPCD100746[!is.na(Gobihadros_mongoliensis_MPCD100746)]
Gobihadros_mongoliensis_MPCD100755 <- Gobihadros_mongoliensis_MPCD100755[!is.na(Gobihadros_mongoliensis_MPCD100755)]
Auroraceratops_rugosus_GJ07913 <- Auroraceratops_rugosus_GJ07913[!is.na(Auroraceratops_rugosus_GJ07913)]
Patagotitan_mayorum_MPEFPV <- Patagotitan_mayorum_MPEFPV[!is.na(Patagotitan_mayorum_MPEFPV)]
Eoraptor_lunensi_PVSJ512 <- Eoraptor_lunensi_PVSJ512[!is.na(Eoraptor_lunensi_PVSJ512)]
Corythosaurus_casuarius <- Corythosaurus_casuarius[!is.na(Corythosaurus_casuarius)]
Caihong._Juji_PMoLB00175 <- Caihong._Juji_PMoLB00175[!is.na(Caihong._Juji_PMoLB00175)]
Eosinopteryx_brevipenna_YFGPT5197 <- Eosinopteryx_brevipenna_YFGPT5197[!is.na(Eosinopteryx_brevipenna_YFGPT5197)]
Rahonavis_ostromi_UA8656 <- Rahonavis_ostromi_UA8656[!is.na(Rahonavis_ostromi_UA8656)]
Changyuraptor_yangi_HGB016 <- Changyuraptor_yangi_HGB016[!is.na(Changyuraptor_yangi_HGB016)]
Herrerasaurus_ischigualastensis_PVL2566 <- Herrerasaurus_ischigualastensis_PVL2566[!is.na(Herrerasaurus_ischigualastensis_PVL2566)]
Herrerasaurus_ischigualastensis_UNSJ53 <- Herrerasaurus_ischigualastensis_UNSJ53[!is.na(Herrerasaurus_ischigualastensis_UNSJ53)]
Ischioceratops_zhuchengensis <- Ischioceratops_zhuchengensis[!is.na(Ischioceratops_zhuchengensis)]
Koreaceratops_hwaseongensis <- Koreaceratops_hwaseongensis[!is.na(Koreaceratops_hwaseongensis)]
# CHOOSE SAMPLE TO ANALYSE
#_________________________________________________________________________________________________
# choose sample
name_to_test <- "Koreaceratops_hwaseongensis"
y_val <- eval(parse(text = paste(name_to_test,"_actual_with_gaps",sep="")))
x_val<-1:length(y_val)
# USE AIC TO DECIDE HOW MANY BREAKS TO USE
#_________________________________________________________________________________________________
# extract AIC for models with 1-3 breakpoints
my_max_it=10
all_mods<-NULL
for(h in 1:4)
{
mod1<-segmented(lm(y_val~x_val),seg.Z=~x_val,psi=NA,control=seg.control(K=h,quant=TRUE,it.max=my_max_it),model=TRUE,nboot=50)
all_mods<-rbind(all_mods,c(h,extractAIC(mod1)[2]))
}
all_mods
my_K<-subset(all_mods,all_mods[,2]==min(all_mods[,2]))[1]
When i run the last section of the code i get the error Error in
crossprod(x, y) :
requires numeric/complex matrix/vector arguments
Not too sure why because I have put it in a data frame, is it because I'm importing the file incorrectly? Not sure how to fix.
in the code below I am grabbing data for three symbols, then I want to apply a simple function(which is a trading strategy) to this data. Ideally, I would then run statistics on those returns, such as those native to PerformanceAnalytics.
library("quantmod")
library("PerformanceAnalytics")
options(scipen=999)
PriceData <- new.env()
Symbols <- c("SPY", "QQQ", "IWM")
StartDt <- as.Date("2015-01-01")
suppressWarnings(getSymbols(Symbols, src="yahoo", env=PriceData, from=StartDt))
x <- list()
for (i in 1:length(Symbols)) {
x[[i]] <- get(Symbols[i], pos=PriceData)
}
SYSTEM <- function(data){
ret<- Delt(Cl(x[[i]]),Op(x[[i]]),type = 'arithmetic')
mavga <- SMA(Cl(x[[i]]), n=10)
mavgb <- SMA(Cl(x[[i]]), n=20)
sig <- ifelse(mavga>mavgb,1,0)+ifelse(mavgb>mavga,-1,0)
sig <- lag(sig,1)
sig[is.na(sig)]=0
strategyreturn <- sig * ret
return(strategyreturn)
}
######I'm doing something wrong here######
y <- lappy(x,SYSTEM)
z <- do.call("cbind", y)
PerformanceTable <- function(returns){
scalar <- 252
CS <- t(Return.cumulative(returns, geometric = FALSE))
SR <- t(SharpeRatio.annualized(returns, scale=scalar, geometric = FALSE))
SOR <- t(SortinoRatio(returns))
MDD <- t(maxDrawdown(returns))
WP <- colSums(returns > 0)/colSums(returns != 0)
WP <- as.data.frame(WP)
ASD = t(sd.annualized(returns, scale=scalar))
Stat <- cbind(CS,SR,SOR,MDD,ASD,WP)
colnames(Stat) <- c("Profit","SharpeRatio", "Sortino","MaxDrawdown", "AnnStdDev", "WinPct")
print("Performance Table")
print(Stat)
return (Stat)
}
Perf <- PerformanceTable(y)
You are almost there, just replace x[[i]] by data in your function:
SYSTEM <- function(data){
ret<- Delt(Cl(data),Op(data),type = 'arithmetic')
mavga <- SMA(Cl(data), n=10)
mavgb <- SMA(Cl(data), n=20)
sig <- ifelse(mavga>mavgb,1,0)+ifelse(mavgb>mavga,-1,0)
sig <- lag(sig,1)
sig[is.na(sig)]=0
strategyreturn <- sig * ret
return(strategyreturn)
}
and add a l to lappy()
y <- lapply(x,SYSTEM)
z <- do.call("cbind", y)
How could I add pixel values to the plot? I can get the values by using click() but I want it to appear in the plot.
library(raster)
r <- raster(nrow=3, ncol=3)
r[] <- 1:ncell(r)
plot(r)
click(r)
Try the following, which is based on pieces cobbled together from the function returned by
getMethod("click", signature="Raster").
myClick <- function(x, n = Inf, id = FALSE, xy = FALSE, cell = FALSE,
type = "n", show = TRUE, ...) {
i <- 0
n <- max(n, 1)
while (i < n) {
i <- i + 1
loc <- locator(1, type, ...)
xyCoords <- cbind(x = loc$x, y = loc$y)
cells <- na.omit(cellFromXY(x, xyCoords))
if (length(cells) == 0)
break
value <- extract(x, cells)
text(xyCoords, labels = value)
}
}
## Try it out
myClick(r, n=4)
If you want to show all values you can use the text method:
library(raster)
r <- raster(nrow=3, ncol=3, vals=1:9)
plot(r)
text(r)
For a subset, you can do something like:
z <- rasterToPoints(r, function(x) x > 6 )
plot(r)
text(z[,1], z[,2], z[,3])
I know this question is already marked as answered, but building on Josh's solution and Eddie's follow-up question, here is a little for-loop that does what Eddie was asking for (plot raster values without decimal numbers and without using click):
r <- raster(nrow=3, ncol=3)
r[] <- runif(ncell(r))
plot(r)
for(i in 1:ncell(r)){
xycoords <- xyFromCell(r, cell = i)
value <- extract(r, xycoords)
text(xycoords, labels = round(value))
}
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
}