I would like to use Plotly in R to create 3D modells of trenches of archaeological excavations. I'm quite successful to plot point and surface data (Example: Vignette of the R package I'm working on), but I would also like to add raster information of the georeferenced profile pictures of the trenches.
I didn't find any way to plot raster data in Plotlys 3D environment. The only solution I came up with so far (thanks to this post) was to create a 3D modell of the profile with SFM using Photoscan, export the coloured mesh as .ply file, fix the header of this file and import it into R to do the plotting with the following example code:
library(geomorph)
library(plotly)
#load data
mesh <- read.ply("plotly/expply8_corr.ply", ShowSpecimen = FALSE)
# extract vertex coordinates
x <- mesh$vb["xpts",]
y <- mesh$vb["ypts",]
z <- mesh$vb["zpts",]
# plot
plot_ly(
x = x, y = y, z = z,
i = mesh$it[1,]-1, j = mesh$it[2,]-1, k = mesh$it[3,]-1,
facecolor = c(mesh$material$color[1, ]),
type = "mesh3d"
)
You'll find the example data here.
Unfortunately this scales really badly. If you increase the mesh resolution everything becomes to slow. I would really like to just add a simple georeferenced raster to keep the performance high and avoid the necessity to create 3D modells of the profiles. Is there a workflow to achieve this with Plotly or an other plotting library?
I found a nice solution with the package rgl. Example:
library(rgl)
library(jpeg)
# download and load picture
download.file(
url = 'https://upload.wikimedia.org/wikipedia/en/6/6d/Chewbacca-2-.jpg',
destfile = "chewbacca.jpg",
mode = 'wb'
)
chewie <- readJPEG("chewbacca.jpg", native = TRUE)
# create some sample data
x <- sort(rnorm(1000))
y <- rnorm(1000)
z <- rnorm(1000) + atan2(x, y)
# plot sample data
plot3d(x, y, z, col = rainbow(1000), size = 5)
# add picture
show2d(
# plot raster
{
par(mar = rep(0, 4))
plot(
0:1, 0:1, type="n",
ann = FALSE, axes = FALSE,
xaxs = "i", yaxs = "i"
)
rasterImage(chewie, 0, 0, 1, 1)
},
# image position and extent
# coordinate order: lower left, lower right, upper right and upper left
x = c(-2, 1, 1, -2),
y = c(-1, -1, 1, 1),
z = c(-3, -3, 2, 2)
)
The pictures have to be georeferenced with other software (photogrammetry in GIS/CAD). If you have the georeferenced raster you just need the coordinates of its corner points to plot it.
Related
So I have this code that produces the exact surface
f = function(x, y){
z = ((x^2)+(3*y^2))*exp(-(x^2)-(y^2))
}
plot3d(f, col = colorRampPalette(c("blue", "white")),
xlab = "X", ylab = "Y", zlab = "Z",
xlim = c(-3, 3), ylim = c(-3, 3),
aspect = c(1, 1, 0.5))
Giving the following plot:
Now I have some code that does a random walk metropolis algorithm to reproduce the above image. I think it works as if I do another plot of these calculated values I get the next image with 500 points. Here is the code
open3d()
plot3d(x0, y0, f(x0, y0), type = "p")
Which gives the following plot:
I know it's hard looking at this still image but being able to rotate the sampling is working.
Now here is my question: How can I use plot3d() so that I can have a surface that connects all these points and gives a more jagged representation of the exact plot? Or how can I have each point in the z axis as a bar from the xy plane? I just want something more 3 dimensional than points and I can't find how to do this.
Thanks for your help
You can do this by triangulating the surface. You don't give us your actual data, but I can create some similar data using
f = function(x, y){
z = ((x^2)+(3*y^2))*exp(-(x^2)-(y^2))
}
x <- runif(500, -3, 3)
y <- runif(500, -3, 3)
z <- f(x, y)
Then the plotting is done using the method in ?persp3d.deldir:
library(deldir)
library(rgl)
col <- colorRampPalette(c("blue", "white"))(20)[1 + round(19*(z - min(z))/diff(range(z)))]
dxyz <- deldir::deldir(x, y, z = z, suppressMsge = TRUE)
persp3d(dxyz, col = col, front = "lines", back = "lines")
This might need some cosmetic fixes, e.g.
aspect3d(2, 2, 1)
After some rotation, this gives me the following plot:
I'm not sure to understand what you want. If my understanding is correct, here is a solution. Define a parametric representation of your surface:
fx <- function(u,v) u
fy <- function(u,v) v
fz <- function(u,v){
((u^2)+(3*v^2))*exp(-(u^2)-(v^2))
}
Let's say you have these points:
x0 <- seq(-3, 3, length.out = 20)
y0 <- seq(-3, 3, length.out = 20)
Then you can use the function parametric3d of the misc3d package, with the option fill=FALSE to get a wireframe:
library(misc3d)
parametric3d(fx, fy, fz, u=x0, v=y0,
color="blue", fill = FALSE)
Is it what you want?
To get some vertical bars, use the function segments3d of rgl:
i <- 8
bar <- rbind(c(x0[i],y0[i],0),c(x0[i],y0[i],f(x0[i],y0[i])))
segments3d(bar, color="red")
Here is a plot with only 50 points using my original code.
When I then apply what was said by Stéphane Laurent I then get this plot which feels too accurate when given the actual points I have
Perhaps you need to explain to me what is actually happening in the function parametric3d
How can I highlight the ten minimum value grid points of a 385*373 levelplot as black points?
I have the indexes as well as the coordinates of the ten minimum grid points. Preferably I would use the idexes...
I have the following levelplot displaying Europe's air temperature (Z), with X and Y being longitude and latitude respectively.
levelplot(Z ~ X*Y, data=data , xlab="X" , col.regions = heat.colors(100))
One further question: how can I add the country contours with the same projection type as the base data? I tried that before within another function
image(x,y,data,...)
data(wrdl_simpl)
plot(wrld_simpl, add = TRUE)
where the country contours plot seemed to have a totally different projection. However, I want to do this for levelplot() now.
I am very thankful for any help!
lattice plots differ to base plots. Therefore using points does not work. But there are replacement functions. Here is a way to do it:
x <- seq(-10, 10, length.out = 100)
y <- seq(-10, 10, length.out = 100)
z <- as.vector(sqrt(outer(x^2, y^2, "+")))
grid <- cbind(expand.grid(x=x, y=y), z)
minimum <- grid[which.min(grid$z),]
levelplot(z ~ x * y, grid, panel = function(...) {
panel.levelplot(...)
panel.points(x = minimum$x, y = minimum$y, pch = "x", cex =2)
})
We are basically building up the plot inside the panel argument.
I found many resources on how to draw Venn diagrams in R. Stack Overflow has a lot of them. However, I still can't draw my diagrams the way I want. Take the following code as an example:
library("VennDiagram")
A <- 1:4
B <- 3:6
d <- list(A, B)
vp <- venn.diagram(d, fill = c("white", "white"), alpha = 1, filename = NULL,
category.names=c("A", "B"))
grid.draw(vp)
I want the intersection between the sets to be red. However, if I change any of the white colors to red, I get the following:
vp_red <- venn.diagram(d, fill = c("red", "white"), alpha = 1, filename = NULL,
category.names=c("A", "B"))
grid.draw(vp_red)
That's not quite what I want. I want only the intersection to be red. If I change the alpha, this is what I get:
vp_alpha <- venn.diagram(d, fill = c("red", "white"), alpha = 0.5, filename = NULL,
category.names=c("A", "B"))
grid.draw(vp_alpha)
Now I have pink in my intersection. This is not what I want as well. What I want is something like this image from Wikipedia:
How can I do this? Maybe VennDiagram package can't do it and I need some other package, but I've been testing different ways to do it, and I'm not being able to find a solution.
I will show two different possibilities. In the first example, polyclip::polyclip is used to get the intersection. In the second example, circles are converted to sp::SpatialPolygons and we get the intersection using rgeos::gIntersection. Then we re-plot the circles and fill the intersecting area.
The resulting object when using venn.diagram is
"of class gList containing the grid objects that make up the diagram"
Thus, in both cases we can grab relevant data from "vp". First, check the structure and list the grobs of the object:
str(vp)
grid.ls()
# GRID.polygon.234
# GRID.polygon.235
# GRID.polygon.236 <~~ these are the empty circles
# GRID.polygon.237 <~~ $ col : chr "black"; $ fill: chr "transparent"
# GRID.text.238 <~~ labels
# GRID.text.239
# GRID.text.240
# GRID.text.241
# GRID.text.242
1. polyclip
Grab x- and y-values, and put them in the format required for polyclip:
A <- list(list(x = as.vector(vp[[3]][[1]]), y = as.vector(vp[[3]][[2]])))
B <- list(list(x = as.vector(vp[[4]][[1]]), y = as.vector(vp[[4]][[2]])))
Find intersection:
library(polyclip)
AintB <- polyclip(A, B)
Grab labels:
ix <- sapply(vp, function(x) grepl("text", x$name, fixed = TRUE))
labs <- do.call(rbind.data.frame, lapply(vp[ix], `[`, c("x", "y", "label")))
Plot it!
plot(c(0, 1), c(0, 1), type = "n", axes = FALSE, xlab = "", ylab = "")
polygon(A[[1]])
polygon(B[[1]])
polygon(AintB[[1]], col = "red")
text(x = labs$x, y = labs$y, labels = labs$label)
2. SpatialPolygons and gIntersection
Grab the coordinates of the circles:
# grab x- and y-values from first circle
x1 <- vp[[3]][["x"]]
y1 <- vp[[3]][["y"]]
# grab x- and y-values from second circle
x2 <- vp[[4]][["x"]]
y2 <- vp[[4]][["y"]]
Convert points to SpatialPolygons and find their intersection:
library(sp)
library(rgeos)
p1 <- SpatialPolygons(list(Polygons(list(Polygon(cbind(x1, y1))), ID = 1)))
p2 <- SpatialPolygons(list(Polygons(list(Polygon(cbind(x2, y2))), ID = 2)))
ip <- gIntersection(p1, p2)
Plot it!
# plot circles
plot(p1, xlim = range(c(x1, x2)), ylim = range(c(y1, y2)))
plot(p2, add = TRUE)
# plot intersection
plot(ip, add = TRUE, col = "red")
# add labels (see above)
text(x = labs$x, y = labs$y, labels = labs$label)
I'm quite sure you could work directly on the grobs using clipping functions in grid or gridSVG package.
It's very easy in eulerr R package
library(eulerr)
plot(euler(c("A"=5,"B"=4,"A&B"=2)),quantities = TRUE,fills=c("white","white","red"))
euler set colours
I want to plot a matrix of z values with x rows and y columns as a surface similar to this graph from MATLAB.
Surface plot:
Code to generate matrix:
# Parameters
shape<-1.849241
scale<-38.87986
x<-seq(from = -241.440, to = 241.440, by = 0.240)# 2013 length
y<-seq(from = -241.440, to = 241.440, by = 0.240)
matrix_fun<-matrix(data = 0, nrow = length(x), ncol = length(y))
# Generate two dimensional travel distance probability density function
for (i in 1:length(x)) {
for (j in 1:length(y)){
dxy<-sqrt(x[i]^2+y[j]^2)
prob<-1/(scale^(shape)*gamma(shape))*dxy^(shape-1)*exp(-(dxy/scale))
matrix_fun[i,j]<-prob
}}
# Rescale 2-d pdf to sum to 1
a<-sum(matrix_fun)
matrix_scale<-matrix_fun/a
I am able to generate surface plots using a couple methods (persp(), persp3d(), surface3d()) but the colors aren't displaying the z values (the probabilities held within the matrix). The z values only seem to display as heights not as differentiated colors as in the MATLAB figure.
Example of graph code and graphs:
library(rgl)
persp3d(x=x, y=y, z=matrix_scale, color=rainbow(25, start=min(matrix_scale), end=max(matrix_scale)))
surface3d(x=x, y=y, z=matrix_scale, color=rainbow(25, start=min(matrix_scale), end=max(matrix_scale)))
persp(x=x, y=y, z=matrix_scale, theta=30, phi=30, col=rainbow(25, start=min(matrix_scale), end=max(matrix_scale)), border=NA)
Image of the last graph
Any other tips to recreate the image in R would be most appreciated (i.e. legend bar, axis tick marks, etc.)
So here's a ggplot solution which seems to come a little bit closer to the MATLAB plot
# Parameters
shape<-1.849241
scale<-38.87986
x<-seq(from = -241.440, to = 241.440, by = 2.40)
y<-seq(from = -241.440, to = 241.440, by = 2.40)
df <- expand.grid(x=x,y=y)
df$dxy <- with(df,sqrt(x^2+y^2))
df$prob <- dgamma(df$dxy,shape=shape,scale=scale)
df$prob <- df$prob/sum(df$prob)
library(ggplot2)
library(colorRamps) # for matlab.like(...)
library(scales) # for labels=scientific
ggplot(df, aes(x,y))+
geom_tile(aes(fill=prob))+
scale_fill_gradientn(colours=matlab.like(10), labels=scientific)
BTW: You can generate your data frame of probabilities much more efficiently using the built-in dgamma(...) function, rather than calculating it yourself.
In line with alexis_laz's comment, here is an example using filled.contour. You might want to increase your by to 2.40 since the finer granularity increases the time it takes to generate the plot by a lot but doesn't improve quality.
filled.contour(x = x, y = y, z = matrix_scale, color = terrain.colors)
# terrain.colors is in the base grDevices package
If you want something closer to your color scheme above, you can fiddle with the rainbow function:
filled.contour(x = x, y = y, z = matrix_scale,
color = (function(n, ...) rep(rev(rainbow(n/2, ...)[1:9]), each = 3)))
Finer granularity:
filled.contour(x = x, y = y, z = matrix_scale, nlevels = 150,
color = (function(n, ...)
rev(rep(rainbow(50, start = 0, end = 0.75, ...), each = 3))[5:150]))
I have a following data:
library(rgl)
x <- c(rep(1,6),
rep(3,6),
rep(6,6),
rep(9,6),
rep(12,6))
y <- c(1.35,1.39,1.48,1.29,1.35,1.32,
NA,1.5,1.44,1.6,1.5,1.41,
NA,NA,1.72,1.56,1.6,1.55,
NA,NA,NA,1.95,1.9,1.75,
NA,NA,NA,NA,2.05,1.95)
z <- rep(1:6,5)
open3d()
plot3d(x,y,z, type = 'n')
lines3d(x,y,z)
Which is plotting lines in 3d as I expect.
But I cannot get it to plot a surface3d.
As I already read some threads I might need to interpolate my data. RGL docs has not cover this subject well. I tried akima but it doesn't accept NA's.
I would like to link lines to create a surface in linear way. I aware of the NA, so I expect that surface will be decreasing in the area for bigger x (more NA's).
Do I need to perform interpolation? If yes, how to do that on my sample data?
If no, how to achieve the surface3d on my sample data?
Thanks
the solution comes to me from this thread:
Making a wireframe plot from an x,y,z data.frame
below code will work for the sample data provided above (just switch x->y,y->z,z->x)
zmat <- matrix(data = z, nrow = 6, ncol = 5, byrow = FALSE)
surface3d(x = 1:6, y = c(1,3,6,9,12), z = zmat, alpha = 0.4, colour = 'blue')