I have a data.frame with two factor variables (type and age in df below) and a single numeric variable (value in df) that I'd like to plot using R's plotly package as a grouped boxplot.
Here's the data.frame:
set.seed(1)
df <- data.frame(type = c(rep("t1", 1000), rep("t2", 1000), rep("t3", 1000), rep("t4", 1000), rep("t5", 1000), rep("t6", 1000)),
age = rep(c(rep("y", 500),rep("o", 500)), 6),
value = rep(c(runif(500, 5, 10), runif(500, 7.5, 12.5)), 6),
stringsAsFactors = F)
df$age <- factor(df$age, levels = c("y", "o"), ordered = T)
Here's how I'm currently plotting it:
library(plotly)
library(dplyr)
plot_ly(x = df$type, y = df$value, name = df$age, color = df$type, type = "box", showlegend = F) %>%
layout(yaxis = list(title = "Diversity"), boxmode = "group", boxgap = 0, boxgroupgap = 0)
Which gives:
My question is whether it is possible to color the lines of the boxes by df$age?
I know that for coloring all the boxes with a single color (e.g., #AFB1B5) I can add to the plot_ly function:
line = list(color = "#AFB1B5")
But that would color all box lines similarly whereas what I'm trying to do is to color them differently by df$age.
There is a way to do this that's not that too complicated, but rather ugly. Or something that is over the top cumbersome (I didn't realize how far I was digging until I was done...)
Before I go too far... I noticed that there is a ton of white space and that you have gaps set to zero. You can add the parameter offsetgroup and get rid of a lot more whitespace. Check it out:
plot_ly(data = df,
x = ~type, y = ~value, name = ~age, offsetgroup = ~type, # <- I'm new!
color = ~type, type = "box", showlegend = F) %>%
layout(yaxis = list(title = "Diversity"),
boxmode = "group", boxgap = 0, boxgroupgap = 0)
With the not-too-complicated-but-kind-of-ugly method
The line is the box outline, the median line, the lines from Q1 to the lower fence, from Q3 to the upper fence, and the whiskers.
I assigned the plot to the object plt for this code. When I checked the object, it didn't have the data element, so I built the plot next.
plt <- plotly_build(plt)
Then I added colors with lapply.
# this looks ugly!
lapply(1:12,
function(i){
nm = plt$x$data[[i]]$name
cr = ifelse(nm == "o",
"#66FF66", "black")
plt$x$data[[i]]$line$color <<- cr # change graph by age
}
)
plt
With the ridiculous-amount-of-code-for-a-few-lines-but-looks-better method
I guess it isn't a few lines. It's 48 lines.
For this method, you need to build the plot like I did in the before (plotly_build), so that the data element is in the plt object.
Then you have to determine the first and third quantile, the IQR, the max and min values between the quantiles and 1.5 * IQR for each type and age grouping so that you have the y values for the lines.
I wrote a function to get the upper and lower fences.
fen <- function(vals){
iq = 1.5 * IQR(vals)
q3 = quantile(vals, 3/4) # top of the box
uf = q3 + iq # top of the fence
vt = max(vals[vals > q3 & vals < uf]) # max value in range
q1 = quantile(vals, 1/4) # btm of the box
bf = q1 - iq # btm of the fence
vb = min(vals[vals < q1 & vals > bf]) # min value in range
sz = function(no){
if(length(no) > 1) {no = no[[1]]}
return(no)
}
vt = sz(vt)
vb = sz(vb)
return(list(vt, vb))
}
Then I used this function and the data to determine the remaining values needed to draw the lines.
df1 <- df %>%
# have to reverse the order or it won't line up
mutate(age = factor(age, levels = c("o", "y"), ordered = T)) %>%
group_by(type, age) %>%
summarise(ufen = fen(value)[[1]], # top of the fence
q3 = quantile(value, 3/4), # top of the box
q1 = quantile(value, 1/4), # btm of the box
dfen = fen(value)[[2]]) # btm of the fence
To plot these new lines, I used shapes which is equivalent to ggplot2 annotations. (annotations in Plotly is primarily for text.)
There are several steps to drawing these lines. First I've started with some things that are essentially the same in every line. After that is a vector that helps place the lines on the x-axis.
# line shape basics; the same for every line
tellMe <- function(shade){
list(type = "line",
line = list(color = shade),
xref = "paper",
yref = "y")
}
# setup for placing lines on the x-axis; these are % of space
xers = c(rep(.0825, 4), rep(.083 * 3, 4), rep(.083 * 5, 4))
Now four lapply statements: the upper fences, the lower fences, the upper whiskers, and the lower whiskers.
lns <- lapply(1:12,
function(i) { # upper fence lines
nm = ifelse(df1[i, ]$age == "o",
"#66FF66", "black")
xb = 1/12 * (i - 1)
xn = xb + (1/6 * xers[[i]])
more = tellMe(nm)
c(x0 = xn, x1 = xn,
y0 = df1[i, ]$q3[[1]], # it's named; this makes it val only
y1 = df1[i, ]$ufen, more)
})
mlns <- lapply(1:12,
function(i) { # lower fence lines
nm = ifelse(df1[i, ]$age == "o",
"#66FF66", "black")
xb = 1/12 * (i - 1)
xn = xb + (1/6 * xers[[i]])
more = tellMe(nm)
c(x0 = xn, x1 = xn,
y0 = df1[i, ]$q1[[1]], # it's named; this makes it val only
y1 = df1[i, ]$dfen, more)
})
# default whisker width is 1/2 the width of the box
# current boxes of 1/4 of the space by type
# with domain [0, 1], the box width is 1/12 * .5, so
# the whisker width is
ww = 1/12 * .5 *.5
# already have the center, so half on each side...
ww = ww * .5
wwlns <- lapply(1:12,
function(i) { # upper fence whisker
nm = ifelse(df1[i, ]$age == "o",
"#66FF66", "black")
xb = 1/12 * (i - 1)
xn = xb + (1/6 * xers[[i]])
more = tellMe(nm)
c(x0 = xn - ww, x1 = xn + ww,
y0 = df1[i, ]$ufen, y1 = df1[i, ]$ufen,
more)
})
wwm <- lapply(1:12,
function(i) { # lower fence whisker
nm = ifelse(df1[i, ]$age == "o",
"#66FF66", "black")
xb = 1/12 * (i - 1)
xn = xb + (1/6 * xers[[i]])
more = tellMe(nm)
c(x0 = xn - ww, x1 = xn + ww,
y0 = df1[i, ]$dfen, y1 = df1[i, ]$dfen,
more)
})
Now you have to concatenate the lists and add them to the plot.
# combine shapes
shp <- append(lns, mlns)
shp <- append(shp, wwlns)
shp <- append(shp, wwm)
plt %>% layout(shapes = shp)
There are OBVIOUSLY better color choices out there.
Is there a neat way to color negative values in red and others in green for a (simplified) time series plot below, using lattice::xyplot?
set.seed(0)
xyplot(zoo(cumsum(rnorm(100))), grid=T)
Lattice is based on grid so you can use grid's clipping functionality
library(lattice)
library(grid)
set.seed(0)
x <- zoo(cumsum(rnorm(100)))
xyplot(x, grid=TRUE, panel = function(x, y, ...){
panel.xyplot(x, y, col="red", ...)
grid.clip(y=unit(0,"native"),just=c("bottom"))
panel.xyplot(x, y, col="green", ...) })
When using type="l" you only have one "line" and it's all one color, so you might instead choose to color points:
set.seed(0); require(zoo); require(lattice)
vals <- zoo(cumsum(rnorm(100)))
png()
xyplot(vals, type=c("l","p"), col=c("red", "green")[1+( vals>0)], grid=T)
dev.off()
I found a solution by, Sundar Dorai-Rag, a fellow now at Google, to a similar request (to color the enclosed areas above and below 0, for which his approach to getting the crossing values for the X's was to invert the results of approx ) as seen here: http://r.789695.n4.nabble.com/shading-under-the-lines-in-a-lattice-xyplot-td793875.html. Instead of coloring the enclosed areas, I gave the borders of the polygons the desired colors and left the interior "transparent":
lpolygon <- function (x, y = NULL, border = NULL, col = NULL, ...) {
require(grid, TRUE)
xy <- xy.coords(x, y)
x <- xy$x
y <- xy$y
gp <- list(...)
if (!is.null(border)) gp$col <- border
if (!is.null(col)) gp$fill <- col
gp <- do.call("gpar", gp)
grid.polygon(x, y, gp = gp, default.units = "native")
}
find.zero <- function(x, y) {
n <- length(y)
yy <- c(0, y)
wy <- which(yy[-1] * yy[-n - 1] < 0)
if(!length(wy)) return(NULL)
xout <- sapply(wy, function(i) {
n <- length(x)
ii <- c(i - 1, i)
approx(y[ii], x[ii], 0)$y
})
xout
}
trellis.par.set(theme = col.whitebg())
png();
xyplot(vals, panel = function(x,y, ...) {
x.zero <- find.zero(x, y)
y.zero <- y > 0
yy <- c(y[y.zero], rep(0, length(x.zero)))
xx <- c(x[y.zero], x.zero)
ord <- order(xx)
xx <- xx[ord]
xx <- c(xx[1], xx, xx[length(xx)])
yy <- c(0, yy[ord], 0)
lpolygon(xx, yy, col="transparent", border = "green")
yy <- c(y[!y.zero], rep(0, length(x.zero)))
xx <- c(x[!y.zero], x.zero)
ord <- order(xx)
xx <- xx[ord]
xx <- c(xx[1], xx, xx[length(xx)])
yy <- c(0, yy[ord], 0)
lpolygon(xx, yy, col = "transparent", border = "red")
panel.abline(h = 0) ;panel.grid(v=-1, h=-1 )
}); dev.off()
I tried writing a custom panel function for this that will break a line on a given value
panel.breakline <- function(x,y,breakat=0,col.line,upper.col="red",lower.col="green",...){
f <- approxfun(x,y)
ff <- function(x) f(x)-breakat
psign <- sign(y-breakat)
breaks <- which(diff(psign) != 0)
interp <- sapply(breaks, function(i) uniroot(ff,c(x[i], x[i+1]))$root)
starts <- c(1,breaks+1)
ends <- c(breaks, length(x))
Map(function(start,end,left,right) {
x <- x[start:end]
y <- y[start:end]
col <- ifelse(y[1]>breakat,upper.col,lower.col)
panel.xyplot(c(left, x, right) ,c(breakat,y,breakat), col.line=col,...)
}, starts, ends, c(NA,interp), c(interp,NA))
}
You can run with
library(zoo)
library(lattice)
set.seed(0)
zz<-zoo(cumsum(rnorm(100)))
xyplot(zz, grid=T, panel.groups=panel.breakline)
And you can change the break point or the colors as well
xyplot(zz, grid=T, panel.groups=panel.breakline,
breakat=2, upper.col="blue", lower.col="orange")
If one was to do it without points, then I'd stick to plot (instead of lattice) and use clip , like in one of the answers here :
Plot a line chart with conditional colors depending on values
dat<- zoo(cumsum(rnorm(100)))
plot(dat, col="red")
clip(0,length(dat),0,max(dat) )
lines(dat, col="green")
I'm attempting to script a contour polar plot in R from interpolated point data. In other words, I have data in polar coordinates with a magnitude value I would like to plot and show interpolated values. I'd like to mass produce plots similar to the following (produced in OriginPro):
My closest attempt in R to this point is basically:
### Convert polar -> cart
# ToDo #
### Dummy data
x = rnorm(20)
y = rnorm(20)
z = rnorm(20)
### Interpolate
library(akima)
tmp = interp(x,y,z)
### Plot interpolation
library(fields)
image.plot(tmp)
### ToDo ###
#Turn off all axis
#Plot polar axis ontop
Which produces something like:
While this is obviously not going to be the final product, is this the best way to go about creating contour polar plots in R?
I can't find anything on the topic other than an archive mailing list dicussion from 2008. I guess I'm not fully dedicated to using R for the plots (though that is where I have the data), but I am opposed to manual creation. So, if there is another language with this capability, please suggest it (I did see the Python example).
EDIT
Regarding the suggestion using ggplot2 - I can't seem to get the geom_tile routine to plot interpolated data in polar_coordinates. I have included code below that illustrates where I'm at. I can plot the original in Cartesian and polar, but I can only get the interpolated data to plot in Cartesian. I can plot the interpolation points in polar using geom_point, but I can't extend that approach to geom_tile. My only guess was that this is related to data order - i.e. geom_tile is expecting sorted/ordered data - I've tried every iteration I can think of sorting the data into ascending/descending azimuth and zenith with no change.
## Libs
library(akima)
library(ggplot2)
## Sample data in az/el(zenith)
tmp = seq(5,355,by=10)
geoms <- data.frame(az = tmp,
zen = runif(length(tmp)),
value = runif(length(tmp)))
geoms$az_rad = geoms$az*pi/180
## These points plot fine
ggplot(geoms)+geom_point(aes(az,zen,colour=value))+
coord_polar()+
scale_x_continuous(breaks=c(0,45,90,135,180,225,270,315,360),limits=c(0,360))+
scale_colour_gradient(breaks=seq(0,1,by=.1),low="black",high="white")
## Need to interpolate - most easily done in cartesian
x = geoms$zen*sin(geoms$az_rad)
y = geoms$zen*cos(geoms$az_rad)
df.ptsc = data.frame(x=x,y=y,z=geoms$value)
intc = interp(x,y,geoms$value,
xo=seq(min(x), max(x), length = 100),
yo=seq(min(y), max(y), length = 100),linear=FALSE)
df.intc = data.frame(expand.grid(x=intc$x,y=intc$y),
z=c(intc$z),value=cut((intc$z),breaks=seq(0,1,.1)))
## This plots fine in cartesian coords
ggplot(df.intc)+scale_x_continuous(limits=c(-1.1,1.1))+
scale_y_continuous(limits=c(-1.1,1.1))+
geom_point(data=df.ptsc,aes(x,y,colour=z))+
scale_colour_gradient(breaks=seq(0,1,by=.1),low="white",high="red")
ggplot(df.intc)+geom_tile(aes(x,y,fill=z))+
scale_x_continuous(limits=c(-1.1,1.1))+
scale_y_continuous(limits=c(-1.1,1.1))+
geom_point(data=df.ptsc,aes(x,y,colour=z))+
scale_colour_gradient(breaks=seq(0,1,by=.1),low="white",high="red")
## Convert back to polar
int_az = atan2(df.intc$x,df.intc$y)
int_az = int_az*180/pi
int_az = unlist(lapply(int_az,function(x){if(x<0){x+360}else{x}}))
int_zen = sqrt(df.intc$x^2+df.intc$y^2)
df.intp = data.frame(az=int_az,zen=int_zen,z=df.intc$z,value=df.intc$value)
## Just to check
az = atan2(x,y)
az = az*180/pi
az = unlist(lapply(az,function(x){if(x<0){x+360}else{x}}))
zen = sqrt(x^2+y^2)
## The conversion looks correct [[az = geoms$az, zen = geoms$zen]]
## This plots the interpolated locations
ggplot(df.intp)+geom_point(aes(az,zen))+coord_polar()
## This doesn't track to geom_tile
ggplot(df.intp)+geom_tile(aes(az,zen,fill=value))+coord_polar()
Final Results
I finally took code from the accepted answer (base graphics) and updated the code. I added a thin plate spline interpolation method, an option to extrapolate or not, data point overlays, and the ability to do continuous colors or segmented colors for the interpolated surface. See the examples below.
PolarImageInterpolate <- function(
### Plotting data (in cartesian) - will be converted to polar space.
x, y, z,
### Plot component flags
contours=TRUE, # Add contours to the plotted surface
legend=TRUE, # Plot a surface data legend?
axes=TRUE, # Plot axes?
points=TRUE, # Plot individual data points
extrapolate=FALSE, # Should we extrapolate outside data points?
### Data splitting params for color scale and contours
col_breaks_source = 1, # Where to calculate the color brakes from (1=data,2=surface)
# If you know the levels, input directly (i.e. c(0,1))
col_levels = 10, # Number of color levels to use - must match length(col) if
#col specified separately
col = rev(heat.colors(col_levels)), # Colors to plot
contour_breaks_source = 1, # 1=z data, 2=calculated surface data
# If you know the levels, input directly (i.e. c(0,1))
contour_levels = col_levels+1, # One more contour break than col_levels (must be
# specified correctly if done manually
### Plotting params
outer.radius = round_any(max(sqrt(x^2+y^2)),5,f=ceiling),
circle.rads = pretty(c(0,outer.radius)), #Radius lines
spatial_res=1000, #Resolution of fitted surface
single_point_overlay=0, #Overlay "key" data point with square
#(0 = No, Other = number of pt)
### Fitting parameters
interp.type = 1, #1 = linear, 2 = Thin plate spline
lambda=0){ #Used only when interp.type = 2
minitics <- seq(-outer.radius, outer.radius, length.out = spatial_res)
# interpolate the data
if (interp.type ==1 ){
Interp <- akima:::interp(x = x, y = y, z = z,
extrap = extrapolate,
xo = minitics,
yo = minitics,
linear = FALSE)
Mat <- Interp[[3]]
}
else if (interp.type == 2){
library(fields)
grid.list = list(x=minitics,y=minitics)
t = Tps(cbind(x,y),z,lambda=lambda)
tmp = predict.surface(t,grid.list,extrap=extrapolate)
Mat = tmp$z
}
else {stop("interp.type value not valid")}
# mark cells outside circle as NA
markNA <- matrix(minitics, ncol = spatial_res, nrow = spatial_res)
Mat[!sqrt(markNA ^ 2 + t(markNA) ^ 2) < outer.radius] <- NA
### Set contour_breaks based on requested source
if ((length(contour_breaks_source == 1)) & (contour_breaks_source[1] == 1)){
contour_breaks = seq(min(z,na.rm=TRUE),max(z,na.rm=TRUE),
by=(max(z,na.rm=TRUE)-min(z,na.rm=TRUE))/(contour_levels-1))
}
else if ((length(contour_breaks_source == 1)) & (contour_breaks_source[1] == 2)){
contour_breaks = seq(min(Mat,na.rm=TRUE),max(Mat,na.rm=TRUE),
by=(max(Mat,na.rm=TRUE)-min(Mat,na.rm=TRUE))/(contour_levels-1))
}
else if ((length(contour_breaks_source) == 2) & (is.numeric(contour_breaks_source))){
contour_breaks = pretty(contour_breaks_source,n=contour_levels)
contour_breaks = seq(contour_breaks_source[1],contour_breaks_source[2],
by=(contour_breaks_source[2]-contour_breaks_source[1])/(contour_levels-1))
}
else {stop("Invalid selection for \"contour_breaks_source\"")}
### Set color breaks based on requested source
if ((length(col_breaks_source) == 1) & (col_breaks_source[1] == 1))
{zlim=c(min(z,na.rm=TRUE),max(z,na.rm=TRUE))}
else if ((length(col_breaks_source) == 1) & (col_breaks_source[1] == 2))
{zlim=c(min(Mat,na.rm=TRUE),max(Mat,na.rm=TRUE))}
else if ((length(col_breaks_source) == 2) & (is.numeric(col_breaks_source)))
{zlim=col_breaks_source}
else {stop("Invalid selection for \"col_breaks_source\"")}
# begin plot
Mat_plot = Mat
Mat_plot[which(Mat_plot<zlim[1])]=zlim[1]
Mat_plot[which(Mat_plot>zlim[2])]=zlim[2]
image(x = minitics, y = minitics, Mat_plot , useRaster = TRUE, asp = 1, axes = FALSE, xlab = "", ylab = "", zlim = zlim, col = col)
# add contours if desired
if (contours){
CL <- contourLines(x = minitics, y = minitics, Mat, levels = contour_breaks)
A <- lapply(CL, function(xy){
lines(xy$x, xy$y, col = gray(.2), lwd = .5)
})
}
# add interpolated point if desired
if (points){
points(x,y,pch=4)
}
# add overlay point (used for trained image marking) if desired
if (single_point_overlay!=0){
points(x[single_point_overlay],y[single_point_overlay],pch=0)
}
# add radial axes if desired
if (axes){
# internals for axis markup
RMat <- function(radians){
matrix(c(cos(radians), sin(radians), -sin(radians), cos(radians)), ncol = 2)
}
circle <- function(x, y, rad = 1, nvert = 500){
rads <- seq(0,2*pi,length.out = nvert)
xcoords <- cos(rads) * rad + x
ycoords <- sin(rads) * rad + y
cbind(xcoords, ycoords)
}
# draw circles
if (missing(circle.rads)){
circle.rads <- pretty(c(0,outer.radius))
}
for (i in circle.rads){
lines(circle(0, 0, i), col = "#66666650")
}
# put on radial spoke axes:
axis.rads <- c(0, pi / 6, pi / 3, pi / 2, 2 * pi / 3, 5 * pi / 6)
r.labs <- c(90, 60, 30, 0, 330, 300)
l.labs <- c(270, 240, 210, 180, 150, 120)
for (i in 1:length(axis.rads)){
endpoints <- zapsmall(c(RMat(axis.rads[i]) %*% matrix(c(1, 0, -1, 0) * outer.radius,ncol = 2)))
segments(endpoints[1], endpoints[2], endpoints[3], endpoints[4], col = "#66666650")
endpoints <- c(RMat(axis.rads[i]) %*% matrix(c(1.1, 0, -1.1, 0) * outer.radius, ncol = 2))
lab1 <- bquote(.(r.labs[i]) * degree)
lab2 <- bquote(.(l.labs[i]) * degree)
text(endpoints[1], endpoints[2], lab1, xpd = TRUE)
text(endpoints[3], endpoints[4], lab2, xpd = TRUE)
}
axis(2, pos = -1.25 * outer.radius, at = sort(union(circle.rads,-circle.rads)), labels = NA)
text( -1.26 * outer.radius, sort(union(circle.rads, -circle.rads)),sort(union(circle.rads, -circle.rads)), xpd = TRUE, pos = 2)
}
# add legend if desired
# this could be sloppy if there are lots of breaks, and that's why it's optional.
# another option would be to use fields:::image.plot(), using only the legend.
# There's an example for how to do so in its documentation
if (legend){
library(fields)
image.plot(legend.only=TRUE, smallplot=c(.78,.82,.1,.8), col=col, zlim=zlim)
# ylevs <- seq(-outer.radius, outer.radius, length = contour_levels+ 1)
# #ylevs <- seq(-outer.radius, outer.radius, length = length(contour_breaks))
# rect(1.2 * outer.radius, ylevs[1:(length(ylevs) - 1)], 1.3 * outer.radius, ylevs[2:length(ylevs)], col = col, border = NA, xpd = TRUE)
# rect(1.2 * outer.radius, min(ylevs), 1.3 * outer.radius, max(ylevs), border = "#66666650", xpd = TRUE)
# text(1.3 * outer.radius, ylevs[seq(1,length(ylevs),length.out=length(contour_breaks))],round(contour_breaks, 1), pos = 4, xpd = TRUE)
}
}
[[major edit]]
I was finally able to add contour lines to my original attempt, but since the two sides of the original matrix that gets contorted don't actually touch, the lines don't match up between 360 and 0 degree. So I've totally rethought the problem, but leave the original post below because it was still kind of cool to plot a matrix that way. The function I'm posting now takes x,y,z and several optional arguments, and spits back something pretty darn similar to your desired examples, radial axes, legend, contour lines and all:
PolarImageInterpolate <- function(x, y, z, outer.radius = 1,
breaks, col, nlevels = 20, contours = TRUE, legend = TRUE,
axes = TRUE, circle.rads = pretty(c(0,outer.radius))){
minitics <- seq(-outer.radius, outer.radius, length.out = 1000)
# interpolate the data
Interp <- akima:::interp(x = x, y = y, z = z,
extrap = TRUE,
xo = minitics,
yo = minitics,
linear = FALSE)
Mat <- Interp[[3]]
# mark cells outside circle as NA
markNA <- matrix(minitics, ncol = 1000, nrow = 1000)
Mat[!sqrt(markNA ^ 2 + t(markNA) ^ 2) < outer.radius] <- NA
# sort out colors and breaks:
if (!missing(breaks) & !missing(col)){
if (length(breaks) - length(col) != 1){
stop("breaks must be 1 element longer than cols")
}
}
if (missing(breaks) & !missing(col)){
breaks <- seq(min(Mat,na.rm = TRUE), max(Mat, na.rm = TRUE), length = length(col) + 1)
nlevels <- length(breaks) - 1
}
if (missing(col) & !missing(breaks)){
col <- rev(heat.colors(length(breaks) - 1))
nlevels <- length(breaks) - 1
}
if (missing(breaks) & missing(col)){
breaks <- seq(min(Mat,na.rm = TRUE), max(Mat, na.rm = TRUE), length = nlevels + 1)
col <- rev(heat.colors(nlevels))
}
# if legend desired, it goes on the right and some space is needed
if (legend) {
par(mai = c(1,1,1.5,1.5))
}
# begin plot
image(x = minitics, y = minitics, t(Mat), useRaster = TRUE, asp = 1,
axes = FALSE, xlab = "", ylab = "", col = col, breaks = breaks)
# add contours if desired
if (contours){
CL <- contourLines(x = minitics, y = minitics, t(Mat), levels = breaks)
A <- lapply(CL, function(xy){
lines(xy$x, xy$y, col = gray(.2), lwd = .5)
})
}
# add radial axes if desired
if (axes){
# internals for axis markup
RMat <- function(radians){
matrix(c(cos(radians), sin(radians), -sin(radians), cos(radians)), ncol = 2)
}
circle <- function(x, y, rad = 1, nvert = 500){
rads <- seq(0,2*pi,length.out = nvert)
xcoords <- cos(rads) * rad + x
ycoords <- sin(rads) * rad + y
cbind(xcoords, ycoords)
}
# draw circles
if (missing(circle.rads)){
circle.rads <- pretty(c(0,outer.radius))
}
for (i in circle.rads){
lines(circle(0, 0, i), col = "#66666650")
}
# put on radial spoke axes:
axis.rads <- c(0, pi / 6, pi / 3, pi / 2, 2 * pi / 3, 5 * pi / 6)
r.labs <- c(90, 60, 30, 0, 330, 300)
l.labs <- c(270, 240, 210, 180, 150, 120)
for (i in 1:length(axis.rads)){
endpoints <- zapsmall(c(RMat(axis.rads[i]) %*% matrix(c(1, 0, -1, 0) * outer.radius,ncol = 2)))
segments(endpoints[1], endpoints[2], endpoints[3], endpoints[4], col = "#66666650")
endpoints <- c(RMat(axis.rads[i]) %*% matrix(c(1.1, 0, -1.1, 0) * outer.radius, ncol = 2))
lab1 <- bquote(.(r.labs[i]) * degree)
lab2 <- bquote(.(l.labs[i]) * degree)
text(endpoints[1], endpoints[2], lab1, xpd = TRUE)
text(endpoints[3], endpoints[4], lab2, xpd = TRUE)
}
axis(2, pos = -1.2 * outer.radius, at = sort(union(circle.rads,-circle.rads)), labels = NA)
text( -1.21 * outer.radius, sort(union(circle.rads, -circle.rads)),sort(union(circle.rads, -circle.rads)), xpd = TRUE, pos = 2)
}
# add legend if desired
# this could be sloppy if there are lots of breaks, and that's why it's optional.
# another option would be to use fields:::image.plot(), using only the legend.
# There's an example for how to do so in its documentation
if (legend){
ylevs <- seq(-outer.radius, outer.radius, length = nlevels + 1)
rect(1.2 * outer.radius, ylevs[1:(length(ylevs) - 1)], 1.3 * outer.radius, ylevs[2:length(ylevs)], col = col, border = NA, xpd = TRUE)
rect(1.2 * outer.radius, min(ylevs), 1.3 * outer.radius, max(ylevs), border = "#66666650", xpd = TRUE)
text(1.3 * outer.radius, ylevs,round(breaks, 1), pos = 4, xpd = TRUE)
}
}
# Example
set.seed(10)
x <- rnorm(20)
y <- rnorm(20)
z <- rnorm(20)
PolarImageInterpolate(x,y,z, breaks = seq(-2,8,by = 1))
code available here: https://gist.github.com/2893780
[[my original answer follows]]
I thought your question would be educational for myself, so I took up the challenge and came up with the following incomplete function. It works similar to image(), wants a matrix as its primary input, and spits back something similar to your example above, minus the contour lines.
[[I edited the code June 6th after noticing that it didn't plot in the order I claimed. Fixed. Currently working on contour lines and legend.]]
# arguments:
# Mat, a matrix of z values as follows:
# leftmost edge of first column = 0 degrees, rightmost edge of last column = 360 degrees
# columns are distributed in cells equally over the range 0 to 360 degrees, like a grid prior to transform
# first row is innermost circle, last row is outermost circle
# outer.radius, By default everything scaled to unit circle
# ppa: points per cell per arc. If your matrix is little, make it larger for a nice curve
# cols: color vector. default = rev(heat.colors(length(breaks)-1))
# breaks: manual breaks for colors. defaults to seq(min(Mat),max(Mat),length=nbreaks)
# nbreaks: how many color levels are desired?
# axes: should circular and radial axes be drawn? radial axes are drawn at 30 degree intervals only- this could be made more flexible.
# circle.rads: at which radii should circles be drawn? defaults to pretty(((0:ncol(Mat)) / ncol(Mat)) * outer.radius)
# TODO: add color strip legend.
PolarImagePlot <- function(Mat, outer.radius = 1, ppa = 5, cols, breaks, nbreaks = 51, axes = TRUE, circle.rads){
# the image prep
Mat <- Mat[, ncol(Mat):1]
radii <- ((0:ncol(Mat)) / ncol(Mat)) * outer.radius
# 5 points per arc will usually do
Npts <- ppa
# all the angles for which a vertex is needed
radians <- 2 * pi * (0:(nrow(Mat) * Npts)) / (nrow(Mat) * Npts) + pi / 2
# matrix where each row is the arc corresponding to a cell
rad.mat <- matrix(radians[-length(radians)], ncol = Npts, byrow = TRUE)[1:nrow(Mat), ]
rad.mat <- cbind(rad.mat, rad.mat[c(2:nrow(rad.mat), 1), 1])
# the x and y coords assuming radius of 1
y0 <- sin(rad.mat)
x0 <- cos(rad.mat)
# dimension markers
nc <- ncol(x0)
nr <- nrow(x0)
nl <- length(radii)
# make a copy for each radii, redimension in sick ways
x1 <- aperm( x0 %o% radii, c(1, 3, 2))
# the same, but coming back the other direction to close the polygon
x2 <- x1[, , nc:1]
#now stick together
x.array <- abind:::abind(x1[, 1:(nl - 1), ], x2[, 2:nl, ], matrix(NA, ncol = (nl - 1), nrow = nr), along = 3)
# final product, xcoords, is a single vector, in order,
# where all the x coordinates for a cell are arranged
# clockwise. cells are separated by NAs- allows a single call to polygon()
xcoords <- aperm(x.array, c(3, 1, 2))
dim(xcoords) <- c(NULL)
# repeat for y coordinates
y1 <- aperm( y0 %o% radii,c(1, 3, 2))
y2 <- y1[, , nc:1]
y.array <- abind:::abind(y1[, 1:(length(radii) - 1), ], y2[, 2:length(radii), ], matrix(NA, ncol = (length(radii) - 1), nrow = nr), along = 3)
ycoords <- aperm(y.array, c(3, 1, 2))
dim(ycoords) <- c(NULL)
# sort out colors and breaks:
if (!missing(breaks) & !missing(cols)){
if (length(breaks) - length(cols) != 1){
stop("breaks must be 1 element longer than cols")
}
}
if (missing(breaks) & !missing(cols)){
breaks <- seq(min(Mat,na.rm = TRUE), max(Mat, na.rm = TRUE), length = length(cols) + 1)
}
if (missing(cols) & !missing(breaks)){
cols <- rev(heat.colors(length(breaks) - 1))
}
if (missing(breaks) & missing(cols)){
breaks <- seq(min(Mat,na.rm = TRUE), max(Mat, na.rm = TRUE), length = nbreaks)
cols <- rev(heat.colors(length(breaks) - 1))
}
# get a color for each cell. Ugly, but it gets them in the right order
cell.cols <- as.character(cut(as.vector(Mat[nrow(Mat):1,ncol(Mat):1]), breaks = breaks, labels = cols))
# start empty plot
plot(NULL, type = "n", ylim = c(-1, 1) * outer.radius, xlim = c(-1, 1) * outer.radius, asp = 1, axes = FALSE, xlab = "", ylab = "")
# draw polygons with no borders:
polygon(xcoords, ycoords, col = cell.cols, border = NA)
if (axes){
# a couple internals for axis markup.
RMat <- function(radians){
matrix(c(cos(radians), sin(radians), -sin(radians), cos(radians)), ncol = 2)
}
circle <- function(x, y, rad = 1, nvert = 500){
rads <- seq(0,2*pi,length.out = nvert)
xcoords <- cos(rads) * rad + x
ycoords <- sin(rads) * rad + y
cbind(xcoords, ycoords)
}
# draw circles
if (missing(circle.rads)){
circle.rads <- pretty(radii)
}
for (i in circle.rads){
lines(circle(0, 0, i), col = "#66666650")
}
# put on radial spoke axes:
axis.rads <- c(0, pi / 6, pi / 3, pi / 2, 2 * pi / 3, 5 * pi / 6)
r.labs <- c(90, 60, 30, 0, 330, 300)
l.labs <- c(270, 240, 210, 180, 150, 120)
for (i in 1:length(axis.rads)){
endpoints <- zapsmall(c(RMat(axis.rads[i]) %*% matrix(c(1, 0, -1, 0) * outer.radius,ncol = 2)))
segments(endpoints[1], endpoints[2], endpoints[3], endpoints[4], col = "#66666650")
endpoints <- c(RMat(axis.rads[i]) %*% matrix(c(1.1, 0, -1.1, 0) * outer.radius, ncol = 2))
lab1 <- bquote(.(r.labs[i]) * degree)
lab2 <- bquote(.(l.labs[i]) * degree)
text(endpoints[1], endpoints[2], lab1, xpd = TRUE)
text(endpoints[3], endpoints[4], lab2, xpd = TRUE)
}
axis(2, pos = -1.2 * outer.radius, at = sort(union(circle.rads,-circle.rads)))
}
invisible(list(breaks = breaks, col = cols))
}
I don't know how to interpolate properly over a polar surface, so assuming you can achieve that and get your data into a matrix, then this function will get it plotted for you. Each cell is drawn, as with image(), but the interior ones are teeny tiny. Here's an example:
set.seed(1)
x <- runif(20, min = 0, max = 360)
y <- runif(20, min = 0, max = 40)
z <- rnorm(20)
Interp <- akima:::interp(x = x, y = y, z = z,
extrap = TRUE,
xo = seq(0, 360, length.out = 300),
yo = seq(0, 40, length.out = 100),
linear = FALSE)
Mat <- Interp[[3]]
PolarImagePlot(Mat)
By all means, feel free to modify this and do with it what you will. Code is available on Github here: https://gist.github.com/2877281
Target Plot
Example Code
library(akima)
library(ggplot2)
x = rnorm(20)
y = rnorm(20)
z = rnorm(20)
t. = interp(x,y,z)
t.df <- data.frame(t.)
gt <- data.frame( expand.grid(X1=t.$x,
X2=t.$y),
z=c(t.$z),
value=cut(c(t.$z),
breaks=seq(-1,1,0.25)))
p <- ggplot(gt) +
geom_tile(aes(X1,X2,fill=value)) +
geom_contour(aes(x=X1,y=X2,z=z), colour="black") +
coord_polar()
p <- p + scale_fill_brewer()
p
ggplot2 then has many options to explore re colour scales, annotations etc. but this should get you started.
Credit to this answer by Andrie de Vries that got me to this solution.
imagine I have a 3 columns matrix
x, y, z
where z is a function of x and y.
I know how to plot a "scatter plot" of these points with
plot3d(x,y,z)
But if I want a surface instead I must use other commands such as surface3d
The problem is that it doesn't accept the same inputs as plot3d
it seems to need a matrix with
(nº elements of z) = (n of elements of x) * (n of elements of x)
How can I get this matrix?
I've tried with the command interp, as I do when I need to use contour plots.
How can I plot a surface directly from x,y,z without calculating this matrix?
If I had too many points this matrix would be too big.
cheers
If your x and y coords are not on a grid then you need to interpolate your x,y,z surface onto one. You can do this with kriging using any of the geostatistics packages (geoR, gstat, others) or simpler techniques such as inverse distance weighting.
I'm guessing the 'interp' function you mention is from the akima package. Note that the output matrix is independent of the size of your input points. You could have 10000 points in your input and interpolate that onto a 10x10 grid if you wanted. By default akima::interp does it onto a 40x40 grid:
require(akima)
require(rgl)
x = runif(1000)
y = runif(1000)
z = rnorm(1000)
s = interp(x,y,z)
> dim(s$z)
[1] 40 40
surface3d(s$x,s$y,s$z)
That'll look spiky and rubbish because its random data. Hopefully your data isnt!
You can use the function outer() to generate it.
Have a look at the demo for the function persp(), which is a base graphics function to draw perspective plots for surfaces.
Here is their first example:
x <- seq(-10, 10, length.out = 50)
y <- x
rotsinc <- function(x,y) {
sinc <- function(x) { y <- sin(x)/x ; y[is.na(y)] <- 1; y }
10 * sinc( sqrt(x^2+y^2) )
}
z <- outer(x, y, rotsinc)
persp(x, y, z)
The same applies to surface3d():
require(rgl)
surface3d(x, y, z)
You could look at using Lattice. In this example I have defined a grid over which I want to plot z~x,y. It looks something like this. Note that most of the code is just building a 3D shape that I plot using the wireframe function.
The variables "b" and "s" could be x or y.
require(lattice)
# begin generating my 3D shape
b <- seq(from=0, to=20,by=0.5)
s <- seq(from=0, to=20,by=0.5)
payoff <- expand.grid(b=b,s=s)
payoff$payoff <- payoff$b - payoff$s
payoff$payoff[payoff$payoff < -1] <- -1
# end generating my 3D shape
wireframe(payoff ~ s * b, payoff, shade = TRUE, aspect = c(1, 1),
light.source = c(10,10,10), main = "Study 1",
scales = list(z.ticks=5,arrows=FALSE, col="black", font=10, tck=0.5),
screen = list(z = 40, x = -75, y = 0))
rgl is great, but takes a bit of experimentation to get the axes right.
If you have a lot of points, why not take a random sample from them, and then plot the resulting surface. You can add several surfaces all based on samples from the same data to see if the process of sampling is horribly affecting your data.
So, here is a pretty horrible function but it does what I think you want it to do (but without the sampling). Given a matrix (x, y, z) where z is the heights it will plot both the points and also a surface. Limitations are that there can only be one z for each (x,y) pair. So planes which loop back over themselves will cause problems.
The plot_points = T will plot the individual points from which the surface is made - this is useful to check that the surface and the points actually meet up. The plot_contour = T will plot a 2d contour plot below the 3d visualization. Set colour to rainbow to give pretty colours, anything else will set it to grey, but then you can alter the function to give a custom palette. This does the trick for me anyway, but I'm sure that it can be tidied up and optimized. The verbose = T prints out a lot of output which I use to debug the function as and when it breaks.
plot_rgl_model_a <- function(fdata, plot_contour = T, plot_points = T,
verbose = F, colour = "rainbow", smoother = F){
## takes a model in long form, in the format
## 1st column x
## 2nd is y,
## 3rd is z (height)
## and draws an rgl model
## includes a contour plot below and plots the points in blue
## if these are set to TRUE
# note that x has to be ascending, followed by y
if (verbose) print(head(fdata))
fdata <- fdata[order(fdata[, 1], fdata[, 2]), ]
if (verbose) print(head(fdata))
##
require(reshape2)
require(rgl)
orig_names <- colnames(fdata)
colnames(fdata) <- c("x", "y", "z")
fdata <- as.data.frame(fdata)
## work out the min and max of x,y,z
xlimits <- c(min(fdata$x, na.rm = T), max(fdata$x, na.rm = T))
ylimits <- c(min(fdata$y, na.rm = T), max(fdata$y, na.rm = T))
zlimits <- c(min(fdata$z, na.rm = T), max(fdata$z, na.rm = T))
l <- list (x = xlimits, y = ylimits, z = zlimits)
xyz <- do.call(expand.grid, l)
if (verbose) print(xyz)
x_boundaries <- xyz$x
if (verbose) print(class(xyz$x))
y_boundaries <- xyz$y
if (verbose) print(class(xyz$y))
z_boundaries <- xyz$z
if (verbose) print(class(xyz$z))
if (verbose) print(paste(x_boundaries, y_boundaries, z_boundaries, sep = ";"))
# now turn fdata into a wide format for use with the rgl.surface
fdata[, 2] <- as.character(fdata[, 2])
fdata[, 3] <- as.character(fdata[, 3])
#if (verbose) print(class(fdata[, 2]))
wide_form <- dcast(fdata, y ~ x, value_var = "z")
if (verbose) print(head(wide_form))
wide_form_values <- as.matrix(wide_form[, 2:ncol(wide_form)])
if (verbose) print(wide_form_values)
x_values <- as.numeric(colnames(wide_form[2:ncol(wide_form)]))
y_values <- as.numeric(wide_form[, 1])
if (verbose) print(x_values)
if (verbose) print(y_values)
wide_form_values <- wide_form_values[order(y_values), order(x_values)]
wide_form_values <- as.numeric(wide_form_values)
x_values <- x_values[order(x_values)]
y_values <- y_values[order(y_values)]
if (verbose) print(x_values)
if (verbose) print(y_values)
if (verbose) print(dim(wide_form_values))
if (verbose) print(length(x_values))
if (verbose) print(length(y_values))
zlim <- range(wide_form_values)
if (verbose) print(zlim)
zlen <- zlim[2] - zlim[1] + 1
if (verbose) print(zlen)
if (colour == "rainbow"){
colourut <- rainbow(zlen, alpha = 0)
if (verbose) print(colourut)
col <- colourut[ wide_form_values - zlim[1] + 1]
# if (verbose) print(col)
} else {
col <- "grey"
if (verbose) print(table(col2))
}
open3d()
plot3d(x_boundaries, y_boundaries, z_boundaries,
box = T, col = "black", xlab = orig_names[1],
ylab = orig_names[2], zlab = orig_names[3])
rgl.surface(z = x_values, ## these are all different because
x = y_values, ## of the confusing way that
y = wide_form_values, ## rgl.surface works! - y is the height!
coords = c(2,3,1),
color = col,
alpha = 1.0,
lit = F,
smooth = smoother)
if (plot_points){
# plot points in red just to be on the safe side!
points3d(fdata, col = "blue")
}
if (plot_contour){
# plot the plane underneath
flat_matrix <- wide_form_values
if (verbose) print(flat_matrix)
y_intercept <- (zlim[2] - zlim[1]) * (-2/3) # put the flat matrix 1/2 the distance below the lower height
flat_matrix[which(flat_matrix != y_intercept)] <- y_intercept
if (verbose) print(flat_matrix)
rgl.surface(z = x_values, ## these are all different because
x = y_values, ## of the confusing way that
y = flat_matrix, ## rgl.surface works! - y is the height!
coords = c(2,3,1),
color = col,
alpha = 1.0,
smooth = smoother)
}
}
The add_rgl_model does the same job without the options, but overlays a surface onto the existing 3dplot.
add_rgl_model <- function(fdata){
## takes a model in long form, in the format
## 1st column x
## 2nd is y,
## 3rd is z (height)
## and draws an rgl model
##
# note that x has to be ascending, followed by y
print(head(fdata))
fdata <- fdata[order(fdata[, 1], fdata[, 2]), ]
print(head(fdata))
##
require(reshape2)
require(rgl)
orig_names <- colnames(fdata)
#print(head(fdata))
colnames(fdata) <- c("x", "y", "z")
fdata <- as.data.frame(fdata)
## work out the min and max of x,y,z
xlimits <- c(min(fdata$x, na.rm = T), max(fdata$x, na.rm = T))
ylimits <- c(min(fdata$y, na.rm = T), max(fdata$y, na.rm = T))
zlimits <- c(min(fdata$z, na.rm = T), max(fdata$z, na.rm = T))
l <- list (x = xlimits, y = ylimits, z = zlimits)
xyz <- do.call(expand.grid, l)
#print(xyz)
x_boundaries <- xyz$x
#print(class(xyz$x))
y_boundaries <- xyz$y
#print(class(xyz$y))
z_boundaries <- xyz$z
#print(class(xyz$z))
# now turn fdata into a wide format for use with the rgl.surface
fdata[, 2] <- as.character(fdata[, 2])
fdata[, 3] <- as.character(fdata[, 3])
#print(class(fdata[, 2]))
wide_form <- dcast(fdata, y ~ x, value_var = "z")
print(head(wide_form))
wide_form_values <- as.matrix(wide_form[, 2:ncol(wide_form)])
x_values <- as.numeric(colnames(wide_form[2:ncol(wide_form)]))
y_values <- as.numeric(wide_form[, 1])
print(x_values)
print(y_values)
wide_form_values <- wide_form_values[order(y_values), order(x_values)]
x_values <- x_values[order(x_values)]
y_values <- y_values[order(y_values)]
print(x_values)
print(y_values)
print(dim(wide_form_values))
print(length(x_values))
print(length(y_values))
rgl.surface(z = x_values, ## these are all different because
x = y_values, ## of the confusing way that
y = wide_form_values, ## rgl.surface works!
coords = c(2,3,1),
alpha = .8)
# plot points in red just to be on the safe side!
points3d(fdata, col = "red")
}
So my approach would be to, try to do it with all your data (I easily plot surfaces generated from ~15k points). If that doesn't work, take several smaller samples and plot them all at once using these functions.
Maybe is late now but following Spacedman, did you try duplicate="strip" or any other option?
x=runif(1000)
y=runif(1000)
z=rnorm(1000)
s=interp(x,y,z,duplicate="strip")
surface3d(s$x,s$y,s$z,color="blue")
points3d(s)