In base R (and in sp), I wish to create arrows with a predefined shape but flexible rotation centered at provided coordinates. I came up with the following function:
my_arrow <- function(x,y, rotate=0, col=par("fg"), cex=1) {
xbase <- c(1.2,0.2,0.2,-1.2, -1.2, 0.2, 0.2)
ybase <- c(0,1,0.5,0.5,-0.5,-0.5,-1)
rotM <- matrix(c(cos(rotate*pi/180), sin(rotate*pi/180), -sin(rotate*pi/180), cos(rotate*pi/180)), nrow=2)
transf <- function(x1,y1) cex * rotM %*% c(x1,y1) + c(x,y)
ans <- t(mapply(transf, xbase, ybase))
polygon(x=ans[,1], y=ans[,2], col=col)
}
This produces the arrow I want if rotation=0, however it gets distorted when I do rotate. For instance,
plot(1:2, type="p", col="white", xlim=c(-5,5), ylim=c(-10,10))
my_arrow(0,0, rotate=45)
produces the chart below.
I think I need to apply some special types of coordinates, but I am stuck. Any ideas?
(The arrows function will not work for me since I have another shape in mind. Using gridBase and some rotated viewports sounds like overkill to me.)
After inspecting the function shapes::rotatexy, I found the solution myself: I need to address the aspect ratio issue. In the end, I came up with the following function which works fine for me:
my_arrow <- function(x,y, rotate=0, col=par("fg"), border=par("fg"), cex=1) {
scale_base <- strwidth("O")/2.4
xbase <- c(1.2,0.2,0.2,-1.2, -1.2, 0.2, 0.2) * scale_base
ybase <- c(0,1,0.5,0.5,-0.5,-0.5,-1) * scale_base
rotM <- matrix(c(cos(rotate*pi/180), sin(rotate*pi/180), -sin(rotate*pi/180), cos(rotate*pi/180)), nrow=2)
transf <- function(x1,y1) cex * rotM %*% c(x1,y1) + c(x,y)
ans <- t(mapply(transf, xbase, ybase))
# this is deliberately taken from shapes::rotatexy
user <- par("usr")
pin <- par("pin")
sy <- user[4] - user[3]
sx <- user[2] - user[1]
ans[,2] <- y + (ans[,2]-y) * sy/sx * pin[1]/pin[2]
polygon(x=ans[,1], y=ans[,2], col=col, border=border)
}
So, when I call:
plot(1:2, type="p", col="white", xlim=c(-5,5), ylim=c(-10,10))
my_arrow(0,0, rotate=45, cex=5)
I get what I wanted:
Related
I have this simple code that plots two intersecting lines:
x <- c(1,2,3,4,5,6)
y2 <- c(6,5,4,3,2,1)
y1 <- c(1,2,3,4,5,6)
plot(x, y1)
plot(x, y1, type="o", col="blue", pch="o", lty=1)
points(x, y2, col="red", pch="*")
lines(x, y2, col="red", lty=1)
I then use the locator() function to manually find the position of the intersection of the two lines, using the coordinates of the intersection to plot a label at the intersection with the text() function, and draw a vertical line at the intersection position with the abline() function.
p <- locator()
text(p$x, p$y+0.4, labels="S")
abline(v=p$x, lty=3)
However, here I have run into a problem as I want thart the vertical line at the intersection position would stop at the intersection (instead of going along the entire y axis).
Can someone give me a hint on how to do this?
You can use segments to draw a line segment between two x, y points, so you can do:
p <- locator()
text(p$x, p$y + 0.4, labels = "S")
segments(p$x, 0, p$x, p$y, lty = 3)
Note also that if your lines are always straight like this you can find the intersection algrebaically, which is more accurate and reproducible than using locator():
dx <- tail(x, 1) - head(x, 1)
dy1 <- tail(y1, 1) - head(y1, 1)
dy2 <- tail(y2, 1) - head(y2, 1)
grad1 <- dy1/dx
grad2 <- dy2/dx
c1 <- y1[1] - grad1 * x[1]
c2 <- y2[1] - grad2 * x[1]
xi <- (c2 - c1)/(grad1 - grad2)
yi <- grad1 * xi + c1
segments(xi, 0, xi, yi, lty = 3)
text(xi, yi + 0.4, labels = "S")
There's a nice answer around to plot a miniature plot within a plot. I wrapped it in a function which works fine for a single plot.
myPlot <- function(x, y) {
# main plot
plot(x)
# calculate position of inset
pp <- par("plt")
x0 <- pp[2] - (pp[2] - pp[1]) * 0.225
x1 <- pp[2] - .01
y0 <- pp[4] - (pp[4] - pp[3]) * 0.225
y1 <- pp[4] - .01
# set position for inset
op <- par(fig=c(x0, x1, y0, y1), mar=c(0, 0, 0, 0), new=TRUE)
# add inset grey background
plot.new()
u <- par("usr")
rect(u[1], u[2], u[4], u[3], col="grey80")
# add inset
par(new=TRUE)
plot(y, col=2)
par(op)
}
myPlot(x, y)
However, when I useMap to loop over several data lists, in order to make multiple plots of this type side by side, there seems to be a mess with the pars. The miniature appears as a new plot and not within the main plot. Also a new device is opened after one iteration (i.e. old plot gets overwritten).
op1 <- par(mfrow=c(1, 2))
Map(function(x, y) myPlot(x, y), list(d0, d0), list(d0_inset, d0_inset))
par(op1)
When I use Map(function(x, y) myPlot(x, y), list(d0, d0), list(d0_inset, d0_inset)) alone, though, there are two perfect plots in the plot queue (of RStudio). Thus the plot.new() and par(new=TRUE) might not be the issue here.
What I actually want is this:
myPlot() should throw a number of main plots with miniatures inside corresponding to the length of the data lists when using Map and fit it into the par(mfrow=...).
Does anyone have a clue how to solve this using base R functionalities?
Data:
x <- data.frame(x = rnorm(150, sd=5), y = rnorm(150, sd=5))
y <- data.frame(x = rnorm(1500, sd=5), y = rnorm(1500, sd=5))
There's a couple of points here Jay. The first is that if you want to continue to use mfrow then it's best to stay away from using par(fig = x) to control your plot locations, since fig changes depending on mfrow and also forces a new plot (though you can override that, as per your question). You can use plt instead, which makes all co-ordinates relative to the space within the fig co-ordinates.
The second point is that you can plot the rectangle without calling plot.new()
The third, and maybe most important, is that you only need to write to par twice: once to change plt to the new plotting co-ordinates (including a new = TRUE to plot it in the same window) and once to reset plt (since new will reset itself). This means the function is well behaved and leaves the par as they were.
Note I have added a parameter, at, that allows you to specify the position and size of the little plot within the larger plot. It uses normalized co-ordinates, so for example c(0, 0.5, 0, 0.5) would be the bottom left quarter of the plotting area. I have set it to default at somewhere near your version's location.
myPlot <- function(x, y, at = c(0.7, 0.95, 0.7, 0.95))
{
# Helper function to simplify co-ordinate conversions
space_convert <- function(vec1, vec2)
{
vec1[1:2] <- vec1[1:2] * diff(vec2)[1] + vec2[1]
vec1[3:4] <- vec1[3:4] * diff(vec2)[3] + vec2[3]
vec1
}
# Main plot
plot(x)
# Gray rectangle
u <- space_convert(at, par("usr"))
rect(u[1], u[3], u[2], u[4], col="grey80")
# Only write to par once for drawing insert plot: change back afterwards
plt <- par("plt")
plt_space <- space_convert(at, plt)
par(plt = plt_space, new = TRUE)
plot(y, col = 2)
par(plt = plt)
}
So we can test it with:
x <- data.frame(x = rnorm(150, sd = 5), y = rnorm(150, sd = 5))
y <- data.frame(x = rnorm(1500, sd = 5), y = rnorm(1500, sd = 5))
myPlot(x, y)
par(mfrow = c(1, 2))
myPlot(x, y)
myPlot(x, y)
par(mfrow = c(2, 2))
for(i in 1:4) myPlot(x, y)
I would like to create a waterfall plot in R (XYYY) from my data.
So far, I use this code:
load("myData.RData")
ls()
dim(data)
##matrix to xyz coords
library(reshape2)
newData <- melt(data, id="Group.1")
dim(newData)
head(newData)
tail(newData)
newDataO <- newData[c(2,1,3)]
head(newDataO)
##color scale for z axis
myColorRamp <- function(colors, values) {
v <- (values - min(values))/diff(range(values))
x <- colorRamp(colors)(v)
rgb(x[,1], x[,2], x[,3], maxColorValue = 255)
}
cols <- myColorRamp(c("darkblue","yellow","darkorange","red","darkred"),newDataO$value)
##3D scatter
library(rgl)
plot3d(newDataO$variable, newDataO$Group.1, newDataO$value, xlab="", ylab="", zlab="", type="p", col=cols, box=FALSE, axes=FALSE)
rgl.postscript("persptrial_060514.eps","eps")
to get this plot:
https://dl.dropboxusercontent.com/u/14906265/persptrial_060514.jpg
I have also use this option in 2d with polygon but the result does not properly show the differential effect between both plots (left vs right).
I do not know whether something like persp3d could do the job but I am not familiar enough with writing code to achieve it. Any help will be very much appreciated.
It seems to me that the simplest way of doing a waterfall plot in R is to add all the lines manually in a loop.
library(rgl)
# Function to plot
f <- function(x, y) sin(10 * x * y) * cos(4 * y^3) + x
nx <- 30
ny <- 100
x <- seq(0, 1, length = nx)
y <- seq(0, 1, length = ny)
z <- outer(x, y, FUN = f)
# Plot function and add lines manually
surface3d(x, y, z, alpha = 0.4)
axes3d()
for (i in 1:nx) lines3d(x[i], y, z[i, ], col = 'white', lwd = 2)
I am attempting to reproduce a Stephen Few graphic with gradient circles that demonstrates the hard wired assumption that light appears from above. Here are the circles:
How can I recreate this? Drawing the circles isn't too bad but adding gradient is where I get thrown. I am thinking grid may create something more crisp but this may be a misconception I have.
Here is the start with drawing circles:
## John Fox circle function
source("http://dl.dropboxusercontent.com/u/61803503/wordpress/circle_fun.txt")
par(mar=rep(1, 4), bg = "grey80")
plot.new()
for (i in seq(0, 1, by = .2)) {
for (j in seq(.6, 1, by = .1)) {
circle(i, j, .5, "cm", , 1)
}
}
Related question: How to use R to build bubble charts with gradient fills
EDIT:
Thought I'd share the results:
And here's the code.
With some repeated use of clip, you can get there.
# set up a blank plot
par(mar=rep(0, 4))
par(bg="#cccccc")
plot(NA,xlim=0:1,ylim=0:1)
# define a function
grad.circ <- function(centrex,centrey,radius,col,resolution) {
colfunc <- colorRampPalette(col)
shades <- colfunc(resolution)
for (i in seq_along(shades) ) {
clip(
centrex - radius,
centrex + radius,
(centrey + radius) - ((i-1) * (radius*2)/length(shades)),
(centrey + radius) - (i * (radius*2)/length(shades))
)
symbols(
centrex,
centrey,
circles=radius,
bg=shades[i],
fg=NA,
add=TRUE,
inches=FALSE
)
}
}
# call the function
grad.circ(0.5,0.5,0.5,c("black", "white"),300)
Result:
EDIT (by Tyler Rinker):
I wanted to add the rest of the code I used to replicate the image:
FUN <- function(plot = TRUE, cols = c("black", "white")) {
plot(NA, xlim=0:1, ylim=0:1, axes=FALSE)
if (plot) {
grad.circ(0.5, 0.5, 0.5, cols, 300)
}
}
FUN2 <- function(){
lapply(1:3, function(i) FUN(,c("white", "black")))
FUN(F)
lapply(1:3, function(i) FUN())
}
X11(10, 4.5)
par(mfrow=c(3, 7))
par(mar=rep(0, 4))
par(bg="gray70")
invisible(lapply(1:3, function(i) FUN2()))
Here is a version using rasters and rasterImage:
image <- as.raster( matrix( seq(0,1,length.out=1001), nrow=1001, ncol=1001) )
tmp <- ( row(image) - 501 ) ^2 + ( col(image) - 501 )^2
image[tmp > 500^2] <- NA
image2 <- as.raster( matrix( seq(1,0, length.out=1001), nrow=1001, ncol=1001) )
image2[ tmp > 500^2 ] <- NA
image3 <- row(image) + col(image)
image3 <- image3/max(image3)
image3[tmp>500^2] <- NA
image4 <- 1-image3
image3 <- as.raster(image3)
image4 <- as.raster(image4)
plot( 0:1, 0:1, type='n', asp=1,ann=FALSE,axes=FALSE)
rect(0,0,1,1, col='grey')
rasterImage(image, 0.2, 0.2, 0.3, 0.3)
rasterImage(image2, 0.6, 0.6, 0.7, 0.7)
rasterImage(image3, 0.6, 0.3, 0.7, 0.4)
rasterImage(image4, 0.3, 0.7, 0.4, 0.8)
Other directions of shading can be made by changing the math a little.
You can do this using the (not on CRAN) package zernike . It's designed to produce various images related to Zernike polynomials, heavily used in optics & astronomy systems. Your desired images are pretty much the second Zernike term.
The author is Author: M.L. Peck (mpeck1#ix.netcom.com) ; I forget exactly where the R-package resides on hte web.
And here's an approach using sp and rgeos (similar application here and here).
library(sp)
library(rgeos)
library(raster)
Create two sets of 9 circles by buffering points, then plot their union to set up the plotting area.
b <- gBuffer(SpatialPoints(cbind(rep(1:3, 3), rep(1:3, each=3))), TRUE,
width=0.45, quadsegs=100)
b2 <- gBuffer(SpatialPoints(cbind(rep(5:7, 3), rep(1:3, each=3))), TRUE,
width=0.45, quadsegs=100)
plot(gUnion(b, b2), border=NA)
Step through the polygons and extract their bounding boxes.
bb <- sapply(b#polygons, bbox)
bb2 <- sapply(b2#polygons, bbox)
Plot stacked segments to simulate a gradient.
segments(rep(bb[1,], each=1000),
mapply(seq, bb[2,], bb[4,], len=1000),
rep(bb[3,], each=1000), col=gray.colors(1000, 0))
segments(rep(bb2[1,], each=1000),
mapply(seq, bb2[2,], bb2[4,], len=1000),
rep(bb2[3,], each=1000), col=rev(gray.colors(1000, 0)))
Difference the union of the SpatialPolygon objects and plot the differenced polygon to mask out the non-circles areas.
plot(gDifference(as(extent(par('usr')), 'SpatialPolygons'), gUnion(b, b2)),
col='gray80', border='gray80', add=TRUE)
For bonus circle smoothness, plot the circles once more, with colour equal to the background colour.
plot(gUnion(b, b2), border='gray80', lwd=2, add=TRUE)
have some data that I would like to add "stippling" to show where it is "important", as they do in the IPCC plots
At the moment I am really struggling with trying to do this in R.
If I make up some test data and plot it:
data <- array(runif(12*6), dim=c(12,6) )
over <- ifelse(data > 0.5, 1, 0 )
image(1:12, 1:6, data)
What I would like to finally do is over-plot some points based on the array "over" on top of the current image.
Any suggestions!??
This should help - I had do do a similar thing before and wrote a function that I posted here.
#required function from www.menugget.blogspot.com
matrix.poly <- function(x, y, z=mat, n=NULL){
if(missing(z)) stop("Must define matrix 'z'")
if(missing(n)) stop("Must define at least 1 grid location 'n'")
if(missing(x)) x <- seq(0,1,,dim(z)[1])
if(missing(y)) y <- seq(0,1,,dim(z)[2])
poly <- vector(mode="list", length(n))
for(i in seq(length(n))){
ROW <- ((n[i]-1) %% dim(z)[1]) +1
COL <- ((n[i]-1) %/% dim(z)[1]) +1
dist.left <- (x[ROW]-x[ROW-1])/2
dist.right <- (x[ROW+1]-x[ROW])/2
if(ROW==1) dist.left <- dist.right
if(ROW==dim(z)[1]) dist.right <- dist.left
dist.down <- (y[COL]-y[COL-1])/2
dist.up <- (y[COL+1]-y[COL])/2
if(COL==1) dist.down <- dist.up
if(COL==dim(z)[2]) dist.up <- dist.down
xs <- c(x[ROW]-dist.left, x[ROW]-dist.left, x[ROW]+dist.right, x[ROW]+dist.right)
ys <- c(y[COL]-dist.down, y[COL]+dist.up, y[COL]+dist.up, y[COL]-dist.down)
poly[[i]] <- data.frame(x=xs, y=ys)
}
return(poly)
}
#make vector of grids for hatching
incl <- which(over==1)
#make polygons for each grid for hatching
polys <- matrix.poly(1:12, 1:6, z=over, n=incl)
#plot
png("hatched_image.png")
image(1:12, 1:6, data)
for(i in seq(polys)){
polygon(polys[[i]], density=10, angle=45, border=NA)
polygon(polys[[i]], density=10, angle=-45, border=NA)
}
box()
dev.off()
Or, and alternative with "stipples":
png("hatched_image2.png")
image(1:12, 1:6, data)
for(i in seq(polys)){
xran <- range(polys[[i]]$x)
yran <- range(polys[[i]]$y)
xs <- seq(xran[1], xran[2],,5)
ys <- seq(yran[1], yran[2],,5)
grd <- expand.grid(xs,ys)
points(grd, pch=19, cex=0.5)
}
box()
dev.off()
Update:
In (very late) response to Paul Hiemstra's comment, here are two more examples with a matrix of higher resolution. The hatching maintains a nice regular pattern, but it is not nice to look at when broken up. The stippled example is much nicer:
n <- 100
x <- 1:n
y <- 1:n
M <- list(x=x, y=y, z=outer(x, y, FUN = function(x,y){x^2 * y * rlnorm(n^2,0,0.2)}))
image(M)
range(M$z)
incl <- which(M$z>5e5)
polys <- matrix.poly(M$x, M$y, z=M$z, n=incl)
png("hatched_image.png", height=5, width=5, units="in", res=400)
op <- par(mar=c(3,3,1,1))
image(M)
for(i in seq(polys)){
polygon(polys[[i]], density=10, angle=45, border=NA, lwd=0.5)
polygon(polys[[i]], density=10, angle=-45, border=NA, lwd=0.5)
}
box()
par(op)
dev.off()
png("stippled_image.png", height=5, width=5, units="in", res=400)
op <- par(mar=c(3,3,1,1))
image(M)
grd <- expand.grid(x=x, y=y)
points(grd$x[incl], grd$y[incl], pch=".", cex=1.5)
box()
par(op)
dev.off()
Do it using the coordinate positioning mechanism of ?image [1].
data(volcano)
m <- volcano
dimx <- nrow(m)
dimy <- ncol(m)
d1 <- list(x = seq(0, 1, length = dimx), y = seq(0, 1, length = dimy), z = m)
With your 'image' constructed that way you keep the structure with the object, and its
coordinates intact. You can collect multiple matrices into a 3D array or as multiple
elements, but you need to augment image() in order to handle that, so I keep them
separate here.
Make a copy of the data to specify an interesting area.
d2 <- d1
d2$z <- d2$z > 155
Use the coordinates to specify which cells are interesting. This is expensive if you have a very big raster, but it's super easy to do.
pts <- expand.grid(x = d2$x, y = d2$y)
pts$over <- as.vector(d2$z)
Set up the plot.
op <- par(mfcol = c(2, 1))
image(d1)
image(d1)
points(pts$x[pts$over], pts$y[pts$over], cex = 0.7)
par(op)
Don't forget to modify the plotting of points to get different effects, in particular a very dense grid with lots of points will take ages to draw all those little circles. pch = "." is a good choice.
Now, do you have some real data to plot on that nice projection? See examples here for some of the options: http://spatial-analyst.net/wiki/index.php?title=Global_datasets
[1] R has classes for more sophisticated handling of raster data, see package sp and raster
for two different approaches.
This is a solution in the spirit of #mdsummer's comment using ggplot2. I first draw the grid, and then draw +'es at the locations where a certain value has been exceeded. Note that ggplot2 works with data.frame's, not with multi-dimensional arrays or matrices. You can use melt from the reshape package to convert from an array / marix to a data.frame flat structure.
Here is a concrete example using the example data from the geom_tile documentation:
pp <- function (n,r=4) {
x <- seq(-r*pi, r*pi, len=n)
df <- expand.grid(x=x, y=x)
df$r <- sqrt(df$x^2 + df$y^2)
df$z <- cos(df$r^2)*exp(-df$r/6)
df
}
require(ggplot2)
dat = pp(200)
over = dat[,c("x","y")]
over$value = with(dat, ifelse(z > 0.5, 1, 0))
ggplot(aes(x = x, y = y), data = dat) +
geom_raster(aes(fill = z)) +
scale_fill_gradient2() +
geom_point(data = subset(over, value == 1), shape = "+", size = 1)
This is probably coming too late, but I'd like to post my answer as a reference too.
One nice option for spatial data is to use the rasterVis package. Once you have a "base" raster object, and the "mask" object, which you will use to draw the stippling, you can do something like:
require(raster)
require(rasterVis)
# Scratch raster objects
data(volcano)
r1 <- raster(volcano)
# Here we are selecting only values from 160 to 180.
# This will be our "mask" layer.
over <- ifelse(volcano >=160 & volcano <=180, 1, NA)
r2 <- raster(over)
# And this is the key step:
# Converting the "mask" raster to spatial points
r.mask <- rasterToPoints(r2, spatial=TRUE)
# Plot
levelplot(r1, margin=F) +
layer(sp.points(r.mask, pch=20, cex=0.3, alpha=0.8))
which resembles the map that the OP was looking for. Parameters of the points such as color, size and type can be fine tuned. ?sp.points provides all the arguments that can be used to do that.