I have a list of points and a list of simplices. I would like to plot the simplices in 3D given their vertices. Essentially, I am looking for the equivalent of segment() in 3D.
Example
Pts<-matrix(c(0,0,0,1,0,0,0,1,0,0,0,1),ncol =3,byrow=TRUE)
Simplex<-c(1,2,3,4)
So, I am looking for a way to input Pts and Simplex and getting a plot of the tetrahedron.
I’ve tried searching but so far the only possibility seems to write out the functions for the linear spaces and plot those. Any tips will be highly appreciated.
With the 'rgl' package:
library(rgl)
vertices <- rbind(
c(0, 0, 0),
c(1, 0, 0),
c(0, 1, 0),
c(0, 0, 1)
)
faces <- combn(4,3)
for(f in 1:4){
triangles3d(rbind(
vertices[faces[1,f],],
vertices[faces[2,f],],
vertices[faces[3,f],]
), color="red", alpha=0.4)
}
You can add the edges and the vertices:
# add edges as thin cylinders
edges <- combn(4, 2)
for(e in 1:6){
shade3d(cylinder3d(rbind(vertices[edges[1,e],],vertices[edges[2,e],]),
radius = 0.02, sides = 30), col="yellow")
}
# add vertices as small spheres
spheres3d(vertices, radius= 0.03, color = "yellow")
Not as pretty or flexible, but here's a base R version using persp and segments for fun:
## empty perspective plot
tm <- persp(matrix(rep(0,4), nrow=2),
xlim=c(-1,1), ylim=c(-1,1), zlim=c(-1,1),
col="#00000000", border=NA, theta=30, phi=50, xlab="x")
## project points into 3d space
tpts <- data.frame(trans3d(pmat=tm, x=Pts[,1], y=Pts[,2], z=Pts[,3]))
## draw each segment
sgs <- combn(seq_len(nrow(tpts)), 2,
FUN=function(r) unlist(tpts[r,]), simplify=FALSE)
lapply(sgs, function(x) segments(x[1], x[3], x[2], x[4], col="red"))
Related
I have a triangle living in a 3d space, I want to plot only the edges of the triangle in an efficient way, since I will repeat it for a huge number of triangles.
I am able to plot it as a coloured surface using the package rgl:
rgl.open()
vertices = c(
0,0,0,1,
1,1,0,1,
0,0,1,1)
col = "blue"
shade3d( tmesh3d(vertices,indices) , col=col)
bg3d(color = "white")
But what I want is just the 3 lines connecting the points.
What I tried was:
vertices = c(
0,0,0,
1,1,0,
0,0,1)
rgl.lines(x=c(vertices[1],vertices[4]),y=c(vertices[2],vertices[5]),z=c(vertices[3],vertices[6]),col="black")
rgl.lines(x=c(vertices[4],vertices[7]),y=c(vertices[5],vertices[8]),z=c(vertices[6],vertices[9]),col="black")
rgl.lines(x=c(vertices[7],vertices[1]),y=c(vertices[8],vertices[2]),z=c(vertices[9],vertices[3]),col="black")
bg3d(color = "white")
However, this approach is considerably slower than the first one (around 10 times when tried on a real mesh).
I am wondering, is there a way to plot with shade3d the triangles as transparent with only their edges?
You should just be able to something like this:
wire3d( tmesh3d(vertices,indices) , col=col)
works for me.
Example using something I found in the rgl docs:
library(rgl)
# A trefoil knot
open3d()
theta <- seq(0, 2*pi, len = 25)
cen <- cbind( sin(theta) + 2*sin(2*theta),
2*sin(3*theta),
cos(theta) - 2*cos(2*theta) )
e1 <- cbind( cos(theta) + 4*cos(2*theta),
6*cos(3*theta),
sin(theta) + 4*sin(2*theta) )
knot <- cylinder3d( center=cen,e1=e1,radius = 0.8, closed = TRUE)
wire3d(addNormals(subdivision3d(knot, depth = 2)), col = "green")
yields:
where as using:
shade3d(addNormals(subdivision3d(knot, depth = 2)), col = "green")
yields:
i tried something like this a few weeks ago (Stackoverflow question):
library("rgl")
CCl4=c(5,5,5,10)
Luminol=c(0.01,0.001,0.005,0.005)
Na2CO3=c(0.01,0.01,0.1,0.05)
plot3d( Luminol, Na2CO3, CCl4, type = "s")
for(i in 1:4){
for(k in 1:4){
segments3d(x=Luminol[c(i,k)],y=Na2CO3[c(i,k)],z=CCl4[c(i,k)])
}
}
I hope this provide a guide for solving your problem
I am looking for a way to add an arrow to a plot in base R, such that the arrow will be filled with a grey-gradient color, like this:
I have seen this solution, but that seems quite complex and not that flexible: I need to draw a great mahy arrows, in a great many plots, all potentially with different length and width.
I am aware of the shape package, but that seems to only be able to fill arrowheads, and does not provide a fillable "base" of the arrow.
Any suggestions?
Here is one way to get you started, along the lines of #MrFlick's suggestion. You probably want to encapsulate this inside a function that will allow you to exert more influence over the size of the arrowhead, the width of the base and arrow head, the smoothness of the gradient, etc.
#empty box
plot(c(-1, 2), c(-1, 10), ,type="n",axes=FALSE, xlab = "", ylab = "")
# plot the arrow, without a fill
polygon(c(0,0,-.25,.5,1.25,1,1,0), y = c(0,6,6, 8,6,6,0,0), border = NA)
# create gradient colors
nslices = 100
cols <- colorRampPalette(colors = c("white", "black"))(nslices)
# split the base of the arrow in nslices and fill each progressively
ys <- seq(0,6, len = nslices + 1)
for (i in 1:nslices) {
polygon(c(0,0,1,1), c(ys[i], ys[i+1], ys[i+1], ys[i]), col = cols[i], border = NA)
}
# add a filled arrowhead
polygon(c(-.25, .5, 1.25, -.25), c(6, 8, 6, 6), col = "black")
This would get you an arrow like this:
HTH, Peter
using the arrow defined in the linked question, now in base graphics
# create a black arrow, saved as external file
library(grid)
png("mask.png")
grid.polygon(c(-0.06, 0.06, 0.06, 0.15, 0, -0.15, -0.06),
c(-5, -5, 2.5, 2, 5, 2, 2.5), gp=gpar(fill="black"),
def="native",
vp=viewport(xs=c(-0.15, 0.15), ys=c(-5, 5)))
dev.off()
## read back in as colour matrix
library(png)
m <- readPNG("mask.png", native=FALSE)
mask <- matrix(rgb(m[,,1],m[,,2],m[,,3]),
nrow=nrow(m))
rmat <- matrix(grey(seq(0,1,length=nrow(m))),
nrow=nrow(m), ncol=ncol(m))
rmat[mask == "#FFFFFF"] <- NA
## use in base plot
set.seed(12321)
plot(1:10, rnorm(10))
rasterImage(rmat, 2, -1, 2.5, 0)
Edit:
you don't have to use a temporary file to create the mask, it's just (much more) convenient than fiddling with logical matrices. Here's a starting point to create the arrow directly as a matrix,
marrow <- function(nr=500, nc=300, col = grey(seq(0, 1, length=nr))){
skin <- matrix(col, nrow=nr, ncol=nc)
head <- lower.tri(matrix(TRUE, nrow=nc/2, ncol=nc/2))
skull <- cbind(head[seq(nc/2,1),], head[seq(nc/2,1),seq(nc/2,1)])
rib <- matrix(TRUE, nrow=nr-nrow(skull), ncol=nc/4)
trunk <- cbind(rib, !rib, !rib, rib)
skeleton <- rbind(skull, trunk)
skin[skeleton] <- NA_character_
skin
}
grid.newpage()
grid.raster(marrow(),
width = unit(1,"npc"),
height=unit(1,"npc"))
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)
I have data in the form (x, y, z) where x and y are not on a regular grid. I wish to display a 2D colormap of these data, with intensity (say, grey scale) mapped to the z variable. An obvious solution is to interpolate (see below) on a regular grid,
d <- data.frame(x=runif(1e3, 0, 30), y=runif(1e3, 0, 30))
d$z = (d$x - 15)^2 + (d$y - 15)^2
library(akima)
d2 <- with(d, interp(x, y, z, xo=seq(0, 30, length = 30),
yo=seq(0, 30, length = 50), duplicate="mean"))
pal1 <- grey(seq(0,1,leng=500))
with(d2, image(sort(x), sort(y), z, useRaster=TRUE, col = pal1))
points(d$x, d$y, col="white", bg=grey(d$z/max(d$z)), pch=21, cex=1,lwd=0.1)
However, this loses the information of the initial mesh (position of the points with actual data), which could be very fine or very rough at certain locations. My preference would be for a delaunay tiling with triangles, which accurately represents the actual location and density of the original data points.
Ideally the solution would
compute the tesselation outside of the plotting function, so that the resulting polygons may be plotted with either ggplot2, lattice, or base graphics
be fast. In my real-life example (~1e5 points), the calculation of the tesselation via deldir can be really slow.
By "tesselation" I mean either Delaunay triangles or Voronoi diagrams, although my preference would be for the former. However it bring the additional complexity of interpolating the colour of each triangle based on the original data points.
Here's a solution based on dirichlet from the maptools package,
d <- data.frame(x=runif(1e3, 0, 30), y=runif(1e3, 0, 30))
d$z = (d$x - 15)^2 + (d$y - 15)^2
library(spatstat)
library(maptools)
W <- ripras(df, shape="rectangle")
W <- owin(c(0, 30), c(0, 30))
X <- as.ppp(d, W=W)
Y <- dirichlet(X)
Z <- as(Y, "SpatialPolygons")
plot(Z, col=grey(d$z/max(d$z)))
I'm still unsure of the way to extract the polygons from this SpatialPolygons class.
Also if there's an easy way to produce the "correct" colors for the associated delaunay tesselation I'd like to hear it.
Here is a lattice solution using deldir
d <- data.frame(x=runif(1e3, 0, 30), y=runif(1e3, 0, 30))
d$z = (d$x - 15)^2 + (d$y - 15)^2
pal1 <- grey(seq(0,1,leng=500))
library(latticeExtra)
levelplot(z~x*y, data=d,
panel = function(...) panel.voronoi(..., points=FALSE),
interpolate=TRUE,
col.regions = colorRampPalette(pal1)(1e3), cut=1e3)
I'm creating some maps from raster files using the "raster" package in R. I'd like to create comparison rasters, showing several maps side by side. It's important for this that the colour scales used are the same for all maps, regardless of the values in each map. For example, if map 1 has values from 0-1, and map 2 has values from 0-0.5, cells with a value of 0.5 should have the same colour on both maps.
For example:
map 1 has values from 0 to 1
map 2 has values from 0 to 0.5
the colour goes from red (lowest) to green (highest)
I would like a value of 0.5 to have the same colour in both maps (i.e. yellow, as halfway between red and green). The current behaviour is that it is yellow in map 1, and green in map 2.
I can't find a way to make this work. I can't see any way to set the range of pixel values to use with the plotting function. setMinMax() doesn't help (as 'plot' always calculates the values). Even trying to set the values by hand (e.g. g1#data#max <- 10) doesn't work (these are ignored when plotting).
Finally, making a stack of the maps (which might be expected to plot everything on the same colour scale) doesn't work either - each map still has it's own colour scale.
Any thoughts on how to do this?
EDIT:
The solution I ended up using is:
plot( d, col=rev( rainbow( 99, start=0,end=1 ) ), breaks=seq(min(minValue( d )),max(maxValue(d)),length.out=100) )
Easy solution now is to use the zlim option.
plot( d, col=rev( rainbow( 99, start=0,end=1 ) ),zlim=c(0,1) )
Since the image::raster function specifies that the image::base arguments can be passed (and suggests that image::base is probably used), wouldn't you just specify the same col= and breaks= arguments to all calls to image::raster? You do need to get the breaks and the col arguments "in sync". The number of colors needs to be one less than the number of breaks. The example below is based on the classic volcano data and the second version shows how a range of values can be excluded from an image:
x <- 10*(1:nrow(volcano))
y <- 10*(1:ncol(volcano))
image(x, y, volcano, col = terrain.colors( length(seq(90, 200, by = 5))-1), axes = FALSE, breaks= seq(90, 200, by = 5) )
axis(1, at = seq(100, 800, by = 100))
axis(2, at = seq(100, 600, by = 100))
box()
title(main = "Maunga Whau Volcano", font.main = 4)
x <- 10*(1:nrow(volcano))
y <- 10*(1:ncol(volcano))
image(x, y, volcano, col = terrain.colors( length(seq(150, 200, by = 5))-1), axes = FALSE, breaks= seq(150, 200, by = 5) )
axis(1, at = seq(100, 800, by = 100))
axis(2, at = seq(100, 600, by = 100))
box()
title(main = "Maunga Whau Volcano Restricted to elevations above 150", font.main = 4)
A specific example would aid this effort.
Added as an answer in response to #Tomas
The answer I ended up using is:
plot( d, col=rev( rainbow( 99, start=0,end=1 ) ),
breaks=seq(min(minValue( d )),max(maxValue(d)),length.out=100) )
There is more work to be done here in 'raster' but here is a hack:
library(raster)
r1 <- r2 <- r3 <- raster(ncol=10, nrow=10)
r1[] <- runif(ncell(r1))
r2[] <- runif(ncell(r2)) / 2
r3[] <- runif(ncell(r3)) * 1.5
r3 <- min(r3, 1)
s <- stack(r1, r2, r3)
brk <- c(0, 0.25, 0.5, 0.75, 1)
par(mfrow=c(1,3))
plot(r1, breaks=brk, col=rainbow(4), legend=F)
plot(r1, breaks=brk, col=rainbow(4), legend.only=T, box=F)
plot(r2, breaks=brk, col=rainbow(4), legend=F)
plot(r1, breaks=brk, col=rainbow(4), legend.only=T, box=F)
plot(r3, breaks=brk, col=rainbow(4), legend=F)
plot(r1, breaks=brk, col=rainbow(4), legend.only=T, box=F)
You can also use the spplot function (sp package)
s <- stack(r1, r2, r3)
sp <- as(s, 'SpatialGridDataFrame')
spplot(sp)
You can also send the values to ggplot (search the r-sig-geo archives for examples)
If your RasterLayer links to a very large file, you might first do, before going to ggplot
r <- sampleRegular(r, size=100000, asRaster=TRUE)
and then perhaps
m <- as.matrix(r)
It did not work for me. I used this script to split the color scale and select the one more suitable according to my data:
plot(d, col=rev(heat.colors(8, alpha = 1)), breaks = seq(0, 0.40, by = 0.05))
A pretty simple solution that should usually work (e.g. with the "plot" function in the raster package) is to set "z axis" limits (which control the colors and the color legend).
E.g. you can do something like:
plot(d, zlim=c(0,1))
where d is a stacked raster object. Or, if you have a bunch of separate rasters d1, d2, d2..., you can just do:
plot(d1, zlim=c(0,1))
plot(d2, zlim=c(0,1))
plot(d3, zlim=c(0,1))
...