Cairo error when plotting data - r

I'm trying to follow the code and steps described on THIS page.
Which is in two parts:
Part 1
library(foreach)
library(doParallel)
library(data.table)
library(raster)
# Time the code
start <- proc.time()
if (!file.exists("./DataSets")) {
dir.create("./DataSets")
}
# Data Source:
# http://sedac.ciesin.columbia.edu/data/set/gpw-v3-population-count/data-download
# Format: .ascii, 1/2 degree, 2000
population.file <- "./Canada/VoteDensityRaster64Bit.tif"
# Load the raster file
population.raster <- raster(population.file)
# Convert the raster file to a points file
population.points <- rasterToPoints(population.raster)
all.data <- as.data.table(population.points)
setnames(all.data, c("x", "y", "population"))
# If you have your data in a CSV file, use this instead
# file <- "./DataSets/NBBuildingsWGS84.csv"
# all.data <- data.table(fread(file))
# The following are used to manipulate various data sets
# colnames(all.data) <- c("Name", "Mass", "Latitude", "Longitude") # Meteorites
# all.data$X <- as.numeric(all.data$X)
# all.data$Y <- as.numeric(all.data$Y)
# all.data$Mass <- as.numeric(all.data$Mass)
startEnd <- function(lats, lngs) {
# Find the "upper left" (NW) and "bottom right" (SE) coordinates
# of a set of data.
#
# Args:
# lats: A list of latitude coordinates
# lngs: A list of longitude coordinates
#
# Returns:
# A list of values corresponding to the northwest-most and
# southeast-most coordinates
# Convert to real number and remove NA values
lats <- na.omit(as.numeric(lats))
lngs <- na.omit(as.numeric(lngs))
topLat <- max(lats)
topLng <- min(lngs)
botLat <- min(lats)
botLng <- max(lngs)
return(c(topLat, topLng, botLat, botLng))
}
startEndVals <- startEnd(all.data$y, all.data$x)
remove(startEnd)
startLat <- startEndVals[1]
endLat <- startEndVals[3]
startLng <- startEndVals[2]
endLng <- startEndVals[4]
remove(startEndVals)
interval.v.num = 200.0
interval.h.num = 800.0
interval.v <- (startLat - endLat) / interval.v.num
interval.h <- (endLng - startLng) / interval.h.num
remove(num_intervals)
lat.list <- seq(startLat, endLat + interval.v, -1*interval.v)
# testLng <- -66.66152983 # Fredericton
# testLat <- 45.96538183 # Fredericton
# Prepare the data to be sent in
# If you have a value you want to sum, use this
data <- all.data[,list(x, y, population)]
# If you want to perform a count, use this
# data <- all.data[,list(x, y)]
# data[,Value:=1]
sumInsideSquare <- function(pointLat, pointLng, data) {
# Sum all the values that fall within a square on a map given a point,
# an interval of the map, and data that contains lat, lng and the values
# of interest
setnames(data, c("lng", "lat", "value"))
# Get data inside lat/lon boundaries
lng.interval <- c(pointLng, pointLng + interval.h)
lat.interval <- c(pointLat - interval.v, pointLat)
data <- data[lng %between% lng.interval][lat %between% lat.interval]
return(sum(data$value))
}
# Debugging
# squareSumTemp <- sumInsideSquare(testLat, testLng, interval, data)
# Given a start longitude and an end longitude, calculate an array of values
# corresponding to the sums for that latitude
calcSumLat <- function(startLng, endLng, lat, data) {
row <- c()
lng <- startLng
while (lng < endLng) {
row <- c(row, sumInsideSquare(lat, lng, data))
lng <- lng + interval.h
}
return(row)
}
# Debugging
# rowTemp <- calcSumLat(startLng, endLng, testLat, interval, data)
# write.csv(rowTemp, file = "Temp.csv", row.names = FALSE)
# Set up parallel computing with the number of cores you have
cl <- makeCluster(detectCores(), outfile = "./Progress.txt")
registerDoParallel(cl)
all.sums <- foreach(lat=lat.list, .packages=c("data.table")) %dopar% {
lat.data <- calcSumLat(startLng, endLng, lat, data)
# Progress indicator that works on Mac/Windows
print((startLat - lat)/(startLat - endLat)*100) # Prints to Progress.txt
lat.data
}
stopCluster(cl = cl)
# Convert to data frame
all.sums.table <- as.data.table(all.sums)
# Save to disk so I don't have to run it again
if (!file.exists("./GeneratedData")) {
dir.create("./GeneratedData")
}
output.file <- "./GeneratedData/VoteDensityHighRes.csv"
write.csv(all.sums.table, file = output.file, row.names = FALSE)
# End timer
totalTime <- proc.time() - start
print(totalTime)
# remove(cl, endLat, endLng, startLat, startLng, lat.list, start, calcSumLat, sumInsideSquare, interval)
Part 2
library(graphics)
library(tcltk)
library(pracma)
# Load the data generated by 01GenerateData.R
plot.data <- read.csv("GeneratedData/VoteDensityHighRes.csv", header=TRUE, stringsAsFactors=FALSE)
# Add padding above/below where there was data
# On top
top.padding <- 1:23
for (i in top.padding) {
plot.data <- cbind(0, plot.data)
}
# On bottom
bottom.padding <- 1:23
for (i in bottom.padding) {
plot.data <- cbind(plot.data, 0)
}
# On left
zero.row <- vector(mode="integer", length=dim(plot.data)[1])
left.padding <- 1:10
for (i in left.padding) {
plot.data <- rbind(zero.row, plot.data)
}
# On right
right.padding <- 1:10
for (i in left.padding) {
plot.data <- rbind(plot.data, zero.row)
}
max <- max(plot.data) # Max value in the data, used for scaling
plottingHeight <- 1000 # Arbitrary number that provides the graph's height
scaleFactor <- 300 # Discovered through trial and error to keep the graph in the boundaries
gap <- plottingHeight / length(plot.data) # Space between lines
# Output the file to a 36 inch by 24 inch SVG canvas
plot.width = 36
plot.height = 24
svg(filename = "./TestPlots/CanadaSG03.svg", pointsize=12, width=plot.width, height=plot.height)
# Create a blank plot
yVals <- as.vector(plot.data[[1]] / max * scaleFactor)
plot(0, 0, xlim=c(0, length(yVals)), ylim=c(0,1100), type="n", las=1, xlab=NA, ylab=NA, bty="n", axes=FALSE)
plotting.threshold <- 0.1
plot.length = length(plot.data)
# Progress bar
pb = tkProgressBar(title = "Plot Progress", label = "", min = 1, max = plot.length, initial = 1, width = 300)
# Plot each line
for (i in 1:plot.length) {
# Grabs a row of data
yVals <- as.vector(plot.data[[i]] / max * scaleFactor)
xVals <- c(0:(length(yVals) - 1))
yVals.smooth = savgol(yVals, 3, forder=4)
polygon(xVals, yVals.smooth + plottingHeight, border = NA, col = "#ffffff")
lines(xVals, yVals.smooth + plottingHeight, col="#cccccc", lwd=1.5)
# Plot the peaks with a darker line.
j <- 2 # Skip padding
while (j <= (length(yVals.smooth) - 2)) {
if ((yVals.smooth[j]) > plotting.threshold | (yVals.smooth[j+1]) > plotting.threshold) {
segments(xVals[j], yVals.smooth[j] + plottingHeight, xVals[j+1], yVals.smooth[j+1] + plottingHeight, col="#000000", lwd=1.5)
} else { } # Do nothing
j <- j + 1
}
plottingHeight <- plottingHeight - gap
# Update the progress bar
info <- sprintf("%d%% Complete", round(i / plot.length * 100))
setTkProgressBar(pb, i, title="Progress", info)
}
dev.off()
Sys.sleep(1)
close(pb) # Close the progress bar after a couple seconds
Everything runs perfect until this part of the code from the second part is running:
yVals <- as.vector(plot.data[[1]] / max * scaleFactor)
plot(0, 0, xlim=c(0, length(yVals)), ylim=c(0,1100), type="n", las=1,xlab=NA, ylab=NA, bty="n", axes=FALSE)
And I get the following error message:
Error in plot.new() : cairo error 'error while writing to output stream'
I'm using R 3.3.1 and Rstudio on windows 10, I've also try to run the code with R 2.15.3.
How can i fix this error?

Related

Loop coordinates of intesected line and an outline - R

Based on this answer How to get the coordinates of an intesected line with an outline - R ,I tried to run a loop using the script below. Any idea why I can not plot all the intersection points and lines? The shape is different than the answer given
Code:
library(ggplot2)
library(sf)
t <- seq(0, 2*pi, by=0.1)
df <- data.frame(x = 13*sin(t)^3,
y = 4*cos(t)-2*cos(3*t)-5*cos(4*t)-cos(2*t))
df <- rbind(df, df[1,]) # close the polygon
meanX <- mean(df$x)
meanY <- mean(df$y)
# Transform your data.frame in a sf polygon (the first and last points
# must have the same coordinates)
#> Linking to GEOS 3.5.1, GDAL 2.1.3, proj.4 4.9.2
poly <- st_sf(st_sfc(st_polygon(list(as.matrix(df)))))
# Choose the angle (in degrees)
rotAngles <- 5
for(angle in seq(0,359,rotAngles)) {
# Find the minimum length for the line segment to be always
# outside the cloud whatever the choosen angle
maxX <- max(abs(abs(df[,"x"]) - abs(meanX)))
maxY <- max(abs(abs(df[,"y"]) - abs(meanY)))
line_length = sqrt(maxX^2 + maxY^2) + 1
# Find the coordinates of the 2 points to draw a line with
# the intended angle.
# This is the gray line on the graph below
line <- rbind(c(meanX,meanY),
c(meanX + line_length * cos((pi/180)*angle),
meanY + line_length * sin((pi/180)*angle)))
# Transform into a sf line object
line <- st_sf(st_sfc(st_linestring(line)))
# Intersect the polygon and line. The result is a two points line
# shown in black on the plot below
intersect_line <- st_intersection(poly, line)
# Extract only the second point of this line.
# This is the intersecting point
intersect_point <- st_coordinates(intersect_line)[2,c("X","Y")]
# Visualise this with ggplot and without geom_sf
# you need first transform back the lines into data.frame
line <- as.data.frame(st_coordinates(line))[,1:2]
intersect_line <- as.data.frame(st_coordinates(intersect_line))[,1:2]
ggplot() + geom_path(data=df, aes(x = x, y = y)) +
geom_line(data=line, aes(x = X, y = Y), color = "gray80", lwd = 3) +
geom_line(data=intersect_line, aes(x = X, y = Y), color = "gray20", lwd = 1) +
geom_point(aes(meanX, meanY), colour="orangered", size=2) +
geom_point(aes(intersect_point["X"], intersect_point["Y"]),
colour="orangered", size=2) +
theme_bw()
}
First we'll go back to #Gilles polygon shape as it is more consistent with his reasoning and presentation:
# Generate a heart shape
t <- seq(0, 2*pi, by=0.1)
df <- data.frame(x = 16*sin(t)^3,
y = 13*cos(t)-5*cos(2*t)-2*cos(3*t)-cos(4*t))
df <- rbind(df, df[1,]) # close the polygon
meanX <- mean(df$x)
meanY <- mean(df$y)
library(sf)
poly <- st_sf(st_sfc(st_polygon(list(as.matrix(df)))))
These elements don't change and don't need to calculated multiple times inside a loop:
maxX <- max(abs(abs(df[,"x"]) - abs(meanX)))
maxY <- max(abs(abs(df[,"y"]) - abs(meanY)))
line_length = sqrt(maxX^2 + maxY^2) + 1
Then your rotAngle and angle:
rotAngle <- 5
angle <- seq(0, 359, rotAngle)
Focusing attention on the for loop, the first line call has elements that do and don't change. Let's make an empty list to hold our results, made outside the for loop, that will hold 2x2 matrices:
line_lst <- list()
for (j in 1:length(angle)) {
line_lst[[j]] <- matrix(nrow = 2, ncol=2)
line_lst[[j]][1,1] <- meanX
line_lst[[j]][1,2] <- meanY
line_lst[[j]][2,1] <- meanX + line_length * cos((pi/180)*angle[j])
line_lst[[j]][2,2] <- meanY + line_length * sin((pi/180)*angle[j])
}
line_lst[[1]]
[,1] [,2]
[1,] 1.225402e-06 0.09131118
[2,] 2.425684e+01 0.09131118
line_lst[[72]]
[,1] [,2]
[1,] 1.225402e-06 0.09131118
[2,] 2.416454e+01 -2.02281169
Those seem reasonable, and this was mainly what I wanted to show, explicating on the LHS[j] <- RHS[j], with the which iteration we're on in 1:length(angle). And on to linestring, intersection, and points,
same make an empty receiver, loop thru:
# here we have mismatch of establishing an `i` counter then
# counting `j`, which look close enough to tired eyes
# this will result in NULL(s)
linestring_lst <- list()
for (i in 1:length(line_lst)) { # this causes future error
linestring_lst[[j]] <- st_sf(st_sfc(st_linestring(line_lst[[j]])))
}
# simply keeping our accounting right, using all `i` or all `j`,
# or staying away from things that look alike and using `k` here
for (k in 1:length(line_lst)) {
linestring_lst[[k]] <- st_sf(st_sfc(st_linestring(line_lst[[k]])))
}
intersection_lst <- list()
for (j in 1:length(linestring_lst)) {
intersection_lst[[j]] <- st_intersection(poly, linestring_lst[[j]])
}
intersect_points <- list()
for (j in 1:length(intersection_lst)) {
intersect_points[[j]] <- st_coordinates(intersection_lst[[j]])[2,c('X','Y')]
}
The things to remember here related to for loops, create your receiver objects outside the loop, index both the LHS[j] and RHS[j] ([ for vector-like receivers, [[ for lists). And having done each of these independently, you can put it all in one for loop.
And final step, take the lists to data.frame(s) for use in ggplot.
intersect_pts_df <- as.data.frame(do.call('rbind', intersect_points))
head(intersect_pts_df, n = 3)
X Y
1 14.96993 0.09131118
2 15.56797 1.45333163
3 15.87039 2.88968964

Segmenting rings i.e. non-full objects in R (in EBIimage or other)

I am relying on edge detection (as opposed to colour detection) to extract features from blood cells. The original image looks like:
I am using the R EBImage package to run a sobel + low pass filter to get to something like this:
library(EBImage)
library(data.table)
img <- readImage("6hr-007-DIC.tif")
#plot(img)
#print(img, short = T)
# 1. define filter for edge detection
hfilt <- matrix(c(1, 2, 1, 0, 0, 0, -1, -2, -1), nrow = 3) # sobel
# rotate horizontal filter to obtain vertical filter
vfilt <- t(hfilt)
# get horizontal and vertical edges
imgH <- filter2(img, hfilt, boundary="replicate")
imgV <- filter2(img, vfilt, boundary="replicate")
# combine edge pixel data to get overall edge data
hdata <- imageData(imgH)
vdata <- imageData(imgV)
edata <- sqrt(hdata^2 + vdata^2)
# transform edge data to image
imgE <- Image(edata)
#print(display(combine(img, imgH, imgV, imgE), method = "raster", all = T))
display(imgE, method = "raster", all = T)
# 2. Enhance edges with low pass filter
hfilt <- matrix(c(1, 1, 1, 1, 1, 1, 1, 1, 1), nrow = 3) # low pass
# rotate horizontal filter to obtain vertical filter
vfilt <- t(hfilt)
# get horizontal and vertical edges
imgH <- filter2(imgE, hfilt, boundary="replicate")
imgV <- filter2(imgE, vfilt, boundary="replicate")
# combine edge pixel data to get overall edge data
hdata <- imageData(imgH)
vdata <- imageData(imgV)
edata <- sqrt(hdata^2 + vdata^2)
# transform edge data to image
imgE <- Image(edata)
plot(imgE)
I would like to know if there are any methods to fill in the holes in the large rings (blood cells) so they are solid bodies a bit like:
(obviously this is not the same image but imagine that last image only started out with edges.)
I would then like to use something like computeFeatures() method from the EBImage package (which as far as I'm aware only works on solid bodies)
EDIT Little more code to extract interior of objects with "connections" to border. The additional code includes defining the convex hull of the segmented cells and creating a filled mask.
The short answer is that fillHull and floodFill may be helpful for filling cells that have well defined borders.
The longer (edited) answer below suggests an approach with floodFill that might be useful. You did a great job extracting information from the low contrast DIC images, but even more image processing might be helpful such as "flat-field correction" for noisy DIC images. The principle is described in this Wikipedia page but a simple implementation does wonders. The coding solution suggested here requires user interaction to select cells. That's not such a robust approach. Still, perhaps more image processing combined with code to locate cells could work. In the end, the interior of cells are segmented and available for analysis with computeFeatures.
The code starts with the thresholded image (having trimmed the edges and converted to binary).
# Set up plots for 96 dpi images
library(EBImage)
dm <- dim(img2)/96
dev.new(width = dm[1], height = dm[2])
# Low pass filter with gblur and make binary
xb <- gblur(img2, 3)
xt <- thresh(xb, offset = 0.0001)
plot(xt) # thresh.jpg
# dev.print(jpeg, "thresh.jpg", width = dm[1], unit = "in", res = 96)
# Keep only "large" objects
xm <- bwlabel(xt)
FS <- computeFeatures.shape(xm)
sel <- which(FS[,"s.area"] < 800)
xe <- rmObjects(xm, sel)
# Make binary again and plot
xe <- thresh(xe)
plot(xe) # trimmed.jpg
# dev.print(jpeg, "trimmed.jpg", width = dm[1], unit = "in", res = 96)
# Choose cells with intact interiors
# This is done by hand here but with more pre-processing, it may be
# possible to have the image suitable for more automated analysis...
pp <- locator(type = "p", pch = 3, col = 2) # marked.jpg
# dev.print(jpeg, "marked.jpg", width = dm[1], unit = "in", res = 96)
# Fill interior of each cell with a unique integer
myCol <- seq_along(pp$x) + 1
xf1 <- floodFill(xe, do.call(rbind, pp), col = myCol)
# Discard original objects from threshold (value = 1) and see
cells1 <- rmObjects(xf1, 1)
plot(colorLabels(cells1))
# dev.print(jpeg, "cells1.jpg", width = dm[1], unit = "in", res = 96)
I need to introduce algorithms to connect integer points between vertices and fill a convex polygon. The code here implements Bresenham's algorithm and uses a simplistic polygon filling routine that works only for convex (simple) polygons.
#
# Bresenham's balanced integer line drawing algorithm
#
bresenham <- function(x, y = NULL, close = TRUE)
{
# accept any coordinate structure
v <- xy.coords(x = x, y = y, recycle = TRUE, setLab = FALSE)
if (!all(is.finite(v$x), is.finite(v$y)))
stop("finite coordinates required")
v[1:2] <- lapply(v[1:2], round) # Bresenham's algorithm IS for integers
nx <- length(v$x)
if (nx == 1) return(list(x = v$x, y = v$y)) # just one point
if (nx > 2 && close == TRUE) { # close polygon by replicating 1st point
v$x <- c(v$x, v$x[1])
v$y <- c(v$y, v$y[1])
nx <- nx + 1
}
# collect result in 'ans, staring with 1st point
ans <- lapply(v[1:2], "[", 1)
# process all vertices in pairs
for (i in seq.int(nx - 1)) {
x <- v$x[i] # coordinates updated in x, y
y <- v$y[i]
x.end <- v$x[i + 1]
y.end <- v$y[i + 1]
dx <- abs(x.end - x); dy <- -abs(y.end - y)
sx <- ifelse(x < x.end, 1, -1)
sy <- ifelse(y < y.end, 1, -1)
err <- dx + dy
# process one segment
while(!(isTRUE(all.equal(x, x.end)) && isTRUE(all.equal(y, y.end)))) {
e2 <- 2 * err
if (e2 >= dy) { # increment x
err <- err + dy
x <- x + sx
}
if (e2 <= dx) { # increment y
err <- err + dx
y <- y + sy
}
ans$x <- c(ans$x, x)
ans$y <- c(ans$y, y)
}
}
# remove duplicated points (typically 1st and last)
dups <- duplicated(do.call(cbind, ans), MARGIN = 1)
return(lapply(ans, "[", !dups))
}
And a simple routine to find interior points of a simple polygon.
#
# Return x,y integer coordinates of the interior of a CONVEX polygon
#
cPolyFill <- function(x, y = NULL)
{
p <- xy.coords(x, y = y, recycle = TRUE, setLab = FALSE)
p[1:2] <- lapply(p[1:2], round)
nx <- length(p$x)
if (any(!is.finite(p$x), !is.finite(p$y)))
stop("finite coordinates are needed")
yc <- seq.int(min(p$y), max(p$y))
xlist <- lapply(yc, function(y) sort(seq.int(min(p$x[p$y == y]), max(p$x[p$y == y]))))
ylist <- Map(rep, yc, lengths(xlist))
ans <- cbind(x = unlist(xlist), y = unlist(ylist))
return(ans)
}
Now these can be used along with ocontour() and chull() to create and fill a convex hull about each segmented cells. This "fixes" those cells with intrusions.
# Create convex hull mask
oc <- ocontour(cells1) # for all points along perimeter
oc <- lapply(oc, function(v) v + 1) # off-by-one flaw in ocontour
sel <- lapply(oc, chull) # find points that define convex hull
xh <- Map(function(v, i) rbind(v[i,]), oc, sel) # new vertices for convex hull
oc2 <- lapply(xh, bresenham) # perimeter points along convex hull
# Collect interior coordinates and fill
coords <- lapply(oc2, cPolyFill)
cells2 <- Image(0, dim = dim(cells1))
for(i in seq_along(coords))
cells2[coords[[i]]] <- i # blank image for mask
xf2 <- xe
for (i in seq_along(coords))
xf2[coords[[i]]] <- i # early binary mask
# Compare before and after
img <- combine(colorLabels(xf1), colorLabels(cells1),
colorLabels(xf2), colorLabels(cells2))
plot(img, all = T, nx = 2)
labs <- c("xf1", "cells1", "xf2", "cells2")
ix <- c(0, 1, 0, 1)
iy <- c(0, 0, 1, 1)
text(dm[1]*96*(ix + 0.05), 96*dm[2]*(iy + 0.05), labels = labs,
col = "white", adj = c(0.05,1))
# dev.print(jpeg, "final.jpg", width = dm[1], unit = "in", res = 96)

How to add heatmap to quantmod::chart_Series?

I would like to plot heatmap(s) below quantmod::chart_Series(). How to add the below heatmap to chart_Series (or xts::plot.xts):
library(quantmod)
# Get data fro symbol from Google Finance
symbol <- "SPY"
src <- "google"
from <- "2017-01-01"
symbolData <- getSymbols(symbol, src=src, from=from, auto.assign=FALSE)
# Calculate simple returns
symbolData.ret <- ROC(Cl(symbolData), type="discrete")
# Calculate lagged autocorrelations (Pearson correlation for each value of lag)
nLags <- 100
averageLength <- 3
symbolData.laggedAutocorr <- matrix(0, nLags, NROW(symbolData.ret))
for (lag in 2: nLags) {
# Set the average length as M
if (averageLength == 0) M <- lag
else M <- averageLength
symbolData.laggedAutocorr[lag, ] <- runCor(symbolData.ret, lag(symbolData.ret, lag), M)
}
symbolData.laggedAutocorr[is.na(symbolData.laggedAutocorr)] <- 0
symbolData.laggedAutocorr.xts <- reclass(t(symbolData.laggedAutocorr), symbolData)ž
subset <- "2017"
chart_Series(symbolData, name=symbol, subset=subset)
# Use transposed symbolData.laggedAutocorr for plot so you have data aligned to symbolData
# How to add the below heatmap to chart_Series?
heatmap(symbolData.laggedAutocorr.xts, Rowv = NA, Colv = NA, na.rm = TRUE, labCol = "")
add_Heatmap <- function(heatmapdata, ...) {
lenv <- new.env()
lenv$plot_ta <- function(x, heatmapdata, ...) {
# fill in body of low level plot calls here
# use a switch based on type of TA to draw: bands, bars, lines, dots...
xsubset <- x$Env$xsubset
#heatmapdata <- heatmapdata[subset] # TODO: Something is wrong if I have a subset here
heatmap(heatmapdata, Rowv=NA, Colv=NA, na.rm=TRUE, labCol="")
#image(1:NROW(heatmapdata), 1:NCOL(heatmapdata), coredata(heatmapdata), axes=FALSE)
}
mapply(function(name, value) {assign(name,value,envir=lenv)},
names(list(heatmapdata=heatmapdata,...)),
list(heatmapdata=heatmapdata,...))
exp <- parse(text=gsub("list","plot_ta",
as.expression(substitute(list(x=current.chob(),
heatmapdata=heatmapdata,
...)))), srcfile=NULL)
chob <- current.chob()
chob$add_frame(ylim=c(0, 0.3), asp=0.3) # need to have a value set for ylim
chob$next_frame()
chob$replot(exp,env=c(lenv, chob$Env),expr=TRUE)
chob
}
chart_Series(symbolData)
add_Heatmap(symbolData.laggedAutocorr.xts)
The above almost works... The issue is that the heatmap or image is plotted over the main part of chart_Series instead below of it. What to do in order for it to plot correctly?
I hope this is useful for other people since I managed to get this working (to a certain level). There are still issues. Please see comments at the end of code below and comment what to do in order to remove those issues.
add_Heatmap <- function(heatmapcol, ..., yvalues=1:NCOL(heatmapcol)) {
lenv <- new.env()
lenv$plot_ta <- function(x, heatmapcol, ...) {
xdata <- x$Env$xdata # internal main series
xsubset <- x$Env$xsubset
heatmapcol <- heatmapcol[xsubset]
x.pos <- 1:NROW(heatmapcol)
segments(axTicksByTime(xdata[xsubset], ticks.on=x$Env$ticks.on),
0,
axTicksByTime(xdata[xsubset], ticks.on=x$Env$ticks.on),
NCOL(heatmapcol), col=x$Env$theme$grid)
# TODO: What is faster polgon or rect (https://stackoverflow.com/questions/15627674/efficiency-of-drawing-rectangles-on-image-matrix-in-r)
# TODO: What is faster for or lapply?
# for (i in 1:NCOL(heatmapcol)) {
# rect(x.pos - 1/2, i - 1/2, x.pos + 1/2, i + 1/2 + 1, col=heatmapcol[x.pos, i], border=NA, ...) # base graphics call
# }
lapply(1:NCOL(heatmapcol), function(i) rect(x.pos - 1/2, i - 1/2, x.pos + 1/2, i + 1/2 + 1, col=heatmapcol[x.pos, i], border=NA, ...))
}
mapply(function(name, value) {assign(name,value,envir=lenv)},
names(list(heatmapcol=heatmapcol, ...)),
list(heatmapcol=heatmapcol, ...))
exp <- parse(text=gsub("list", "plot_ta",
as.expression(substitute(list(x=current.chob(),
heatmapcol=heatmapcol,
...)))), srcfile=NULL)
chob <- current.chob()
# chob$add_frame(ylim=c(0, 1),asp=0.15) # add the header frame
# chob$next_frame() # move to header frame
chob$add_frame(ylim=c(1, NCOL(heatmapcol)), asp=1) # need to have a value set for ylim
chob$next_frame()
if (length(yvalues) != NCOL(heatmapcol)) {
# We have a case when min and max is specified
yvalues <- (range(yvalues)[1]):(range(yvalues)[2])
}
# add grid lines
lenv$grid_lines_val <- function(xdata, x) {
ret <- pretty(yvalues)
if (ret[1] != min(yvalues)) {
if (ret[1] <= min(yvalues)) {
ret[1] <- min(yvalues)
} else {
ret <- c(min(yvalues), ret)
}
}
if (ret[length(ret)] != max(yvalues)) {
if (ret[length(ret)] >= max(yvalues)) {
ret[length(ret)] <- max(yvalues)
} else {
ret <- c(ret, max(yvalues))
}
}
return(ret)
}
lenv$grid_lines_pos <- function(xdata, x) {
ret <- lenv$grid_lines_val(xdata, x)
ret <- ret - min(yvalues)
return(ret)
}
exp <- c(exp,
# Add axis labels/boxes
expression(text(1- 1/3 - max(strwidth(grid_lines_val(xdata, xsubset))), grid_lines_pos(xdata, xsubset),
noquote(format(grid_lines_val(xdata, xsubset), justify="right")),
col=theme$labels, offset=0, pos=4, cex=0.9)),
expression(text(NROW(xdata[xsubset]) + 1/3, grid_lines_pos(xdata, xsubset),
noquote(format(grid_lines_val(xdata, xsubset), justify="right")),
col=theme$labels, offset=0, pos=4, cex=0.9)))
chob$replot(exp, env=c(lenv, chob$Env), expr=TRUE)
chob
}
colorsForHeatmap<-function(heatmapdata) {
heatmapdata <- 0.5*(heatmapdata + 1)
r <- coredata((heatmapdata > 0.5)*round(255*(2 - 2*heatmapdata)) + (heatmapdata <= 0.5)*255)
g <- coredata((heatmapdata > 0.5)*255 + (heatmapdata <= 0.5)*round(255*2*heatmapdata))
b <- coredata(heatmapdata*0.0) # Set to 0 for all
col <- rgb(r, g, b, maxColorValue=255)
dim(col) <- dim(r)
col <- reclass(col, heatmapdata)
return(col)
}
library(quantmod)
# Get data for symbol from Google Finance
symbol <- "SPY"
src <- "google"
from <- "1990-01-01"
symbolData <- getSymbols(symbol, src=src, from=from, auto.assign=FALSE)
# Calculate simple returns
symbolData.ret <- ROC(Cl(symbolData), type="discrete")
# Calculate lagged autocorrelations (Pearson correlation for each value of lag)
nLags <- 48
averageLength <- 3
symbolData.laggedAutocorr <- matrix(0, NROW(symbolData.ret), nLags)
for (lag in 2:nLags) {
# Set the average length as M
if (averageLength == 0) M <- lag
else M <- averageLength
symbolData.laggedAutocorr[, lag] <- runCor(symbolData.ret, lag(symbolData.ret, lag), M)
}
symbolData.laggedAutocorr[is.na(symbolData.laggedAutocorr)] <- 0
symbolData.laggedAutocorr.xts <- xts(symbolData.laggedAutocorr, index(symbolData))
heatmapColData <- colorsForHeatmap(symbolData.laggedAutocorr.xts)
symbolData.rsi2 <- RSI(Cl(symbolData), n=2)
subset <- "2011/"
chart_Series(symbolData, name=symbol, subset=subset)
add_Heatmap(heatmapColData, yvalues=2:nLags)
# TODO: There are still issues:
# - add a horizontal line
five <- symbolData[, 1]
five[, 1] <- 5
add_TA(five, col="violet", on=3)
#> add_TA(five, col="violet", on=3)
#Error in ranges[[frame]] : subscript out of bounds
# - add RSI for example and heatmap disappears
add_RSI()
# - or add TA
add_TA(symbolData.rsi2)
# What to do so it works like intended: I can add lines on top of heatmaps? I can add other TAs in new panes?

Circadian Phase plot in R

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);

How does one turn contour lines into filled contours?

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
}

Resources