Drawing a smooth implicit surface with misc3d - r

The misc3d package provides a great implementation of the marching cubes algorithm, allowing to plot implicit surfaces.
For example, let's plot a Dupin cyclide:
a = 0.94; mu = 0.56; c = 0.34 # cyclide parameters
f <- function(x, y, z, a, c, mu){ # implicit equation f(x,y,z)=0
b <- sqrt(a^2-c^2)
(x^2+y^2+z^2-mu^2+b^2)^2 - 4*(a*x-c*mu)^2 - 4*b^2*y^2
}
# define the "voxel"
nx <- 50; ny <- 50; nz <- 25
x <- seq(-c-mu-a, abs(mu-c)+a, length=nx)
y <- seq(-mu-a, mu+a, length=ny)
z <- seq(-mu-c, mu+c, length=nz)
g <- expand.grid(x=x, y=y, z=z)
voxel <- array(with(g, f(x,y,z,a,c,mu)), c(nx,ny,nz))
# plot the surface
library(misc3d)
surf <- computeContour3d(voxel, level=0, x=x, y=y, z=z)
drawScene.rgl(makeTriangles(surf))
Nice, except that the surface is not smooth.
The documentation of drawScene.rgl says: "Object-specific rendering features such as smoothing and material are controlled by setting in the objects." I don't know what does that mean. How to get a smooth surface?
I have a solution but not a straightforward one: this solution consists in building a mesh3d object from the output of computeContour3d, and to include the surface normals in this mesh3d.
The surface normals of an implicit surface defined by f(x,y,z)=0 are simply given by the gradient of f. It is not hard to derive the gradient for this example.
gradient <- function(xyz,a,c,mu){
x <- xyz[1]; y <- xyz[2]; z <- xyz[3]
b <- sqrt(a^2-c^2)
c(
2*(2*x)*(x^2+y^2+z^2-mu^2+b^2) - 8*a*(a*x-c*mu),
2*(2*y)*(x^2+y^2+z^2-mu^2+b^2) - 8*b^2*y,
2*(2*z)*(x^2+y^2+z^2-mu^2+b^2)
)
}
Then the normals are computed as follows:
normals <- apply(surf, 1, function(xyz){
gradient(xyz,a,c,mu)
})
Now we are ready to make the mesh3d object:
mesh <- list(vb = rbind(t(surf),1),
it = matrix(1:nrow(surf), nrow=3),
primitivetype = "triangle",
normals = rbind(-normals,1))
class(mesh) <- c("mesh3d", "shape3d")
And finally to plot it with rgl:
library(rgl)
shade3d(mesh, color="red")
Nice, the surface is smooth now.
But is there a more straightforward way to get a smooth surface, without building a mesh3d object? What do they mean in the documentation: "Object-specific rendering features such as smoothing and material are controlled by setting in the objects."?

I don't know what the documentation is suggesting. However, you can do it via a mesh object slightly more easily than you did (though the results aren't quite as nice), using the addNormals() function to calculate the normals automatically rather than by formula.
Here are the steps:
Compute the surface as you did.
Create the mesh without normals. This is basically what you did, but using tmesh3d():
mesh <- tmesh3d(t(surf), matrix(1:nrow(surf), nrow=3), homogeneous = FALSE)
Calculate which vertices are duplicates of which others:
verts <- apply(mesh$vb, 2, function(column) paste(column, collapse = " "))
firstcopy <- match(verts, verts)
Rewrite the indices to use the first copy. This is necessary, since the misc3d functions give a collection of disconnected triangles; we need to work out which are connected.
it <- as.numeric(mesh$it)
it <- firstcopy[it]
dim(it) <- dim(mesh$it)
mesh$it <- it
At this point, there are a lot of unused vertices in the mesh; if memory was a problem you might want to add a step to remove them. I'm going to skip that.
Add the normals
mesh <- addNormals(mesh)
Here are the before and after shots. Left is without normals, right is with them.
It's not quite as smooth as your solution using computed normals, but it's not always easy to find those.

There's an option smooth in the makeTriangles function:
drawScene.rgl(makeTriangles(surf, smooth=TRUE))
I think the result is equivalent to #user2554330's solution, but this is more straightforward.
EDIT
The result is highly better with the rmarchingcubes package:
library(rmarchingcubes)
contour_shape <- contour3d(
griddata = voxel, level = 0,
x = x, y = y, z = z
)
library(rgl)
tmesh <- tmesh3d(
vertices = t(contour_shape[["vertices"]]),
indices = t(contour_shape[["triangles"]]),
normals = contour_shape[["normals"]],
homogeneous = FALSE
)
open3d(windowRect = c(50, 50, 562, 562))
view3d(zoom=0.8)
shade3d(tmesh, color = "darkred")

Related

How to circle variable to observed (not latent) variables in dagitty plot

How would I put a circle around certaiin variables in the following plot?
library(dagitty)
g = dagitty('dag{
A [pos="-1,0.5"]
W [pos="0.893,-0.422"]
X [adjusted,pos="0,-0.5"]
Y [pos="1,0.5"]
A -> Y
X -> A
X -> W
X -> Y
}')
png("mp.png", width = 500, height = 500,res=300)
plot(g)
dev.off()
In the web based tool you can indicate eg latent or adjusted and it changes the color of the circle, but this is not quite what I am looking for, although if it were possible to get these in the plot from R that would be sufficient, although I don't really like the way the variable is next to the circle in the web based version. I really wanted to circle observed variables and not circle unobserved ones.
I wrote a function which takes the points you want to circle as input, extracts the position of said points and circles them.
library(dagitty)
g = dagitty('dag{
A [pos="-1,0.5"]
W [pos="0.893,-0.422"]
X [adjusted,pos="0,-0.5"]
Y [pos="1,0.5"]
A -> Y
X -> A
X -> W
X -> Y
}')
circle_points <- function(points_to_circle, g) {
#few regexs to extract the points and the positions from "g"
#can surely be optimized, made nicer and more robust but it works for now
fsplit <- strsplit(g[1], "\\]")[[1]]
fsplit <- fsplit[-length(fsplit)]
fsplit <- substr(fsplit, 1, nchar(fsplit)-1)
fsplit[1] <- substr(fsplit[1], 6, nchar(fsplit))
vars <- sapply(regmatches(fsplit,
regexec("\\\n(.*?)\\s*\\[", fsplit)), "[", 2)
pos <- sub(".*pos=\\\"", "", fsplit)
#build dataframe with extracted information
res_df <- data.frame(vars = vars,
posx = sapply(strsplit(pos, ","), "[",1),
posy = sapply(strsplit(pos, ","), "[",2))
df_to_circle <- res_df[res_df$vars %in% points_to_circle,]
#y-position seems to be inverted and has to be multiplied by -1
points(c(as.numeric(df_to_circle$posx)),
c(as.numeric(df_to_circle$posy) * -1),
cex = 4)
}
plot(g)
circle_points(c("A", "Y"), g)
This results in:
You can of course work with the cex parameter, adding colors etc. It seems that the positioning of the circles is a bit off-centered so maybe manipulate the x and y positions in circle_points by a slim margin.
I did not find any information in dagitty, but bnlearn package can add circle/or other shape easily. But I just noticed you only want to add circle to observed traits rather than latent variables (better mentioned this in your title). Then my code might not be what you are looking for. I still attached the code here for your reference. Alternatively, you can distinguish observed/latent traits in different color. This can be easily done using bnlearn (https://www.bnlearn.com/examples/graphviz-plot/)
library(bnlearn)
tree = model2network("[X][W|X][A|X][Y|A:X]")
graphviz.plot(tree, main = "DAG structure", shape = "circle",
layout = "circo")

Implementing a different Kernel for 2D Kernel Density Estimation in R

I'm looking for some help understanding how to implement a 2-dimensional kernel density method, with a isotropic variance, and a bivariate normal kernel, kind of, but instead of using the typical distance, because the data is on the surface of the earth, I need to use a great-circle distance.
I'd like to replicate this in R, but I can't figure out how to use a distance metric other than the simple euclidean distance for any of the built in estimators, and since it uses a complex method with convolutions to add the kernels. Does anyone have a way to program an arbitrary kernel?
I ended up modifying the kde2d function from the MASS library. Some significant revision was needed, as is shown below. That said, the code is very flexible, allowing an arbitrary 2-d kernel to be used. (rdist.earth() was used for the great circle distance, h is the chosen bandwidth, in this case, in km, and n is the number of grid points in each direction to be used. rdist.earth requires the "fields" library)
The function could be modified to perform calculations in more than 2d, but the grid gets large very fast in higher dimensions. (Not that it's small now.)
Comments and suggestions on elegance or performance are welcome!
kde2d_mod <- function (data, h, n = 200, lims = c(range(data$lat), range(data$lon))) {
#Data is a matrix: lon,lat for each source. (lon,lat to match rdist.earth format.)
print(Sys.time()) #for timing
nx <- dim(data)[1]
if (dim(data)[2] != 2)
stop("data vectors have only lat-long data")
if (any(!is.finite(data)))
stop("missing or infinite values in the data are not allowed")
if (any(!is.finite(lims)))
stop("only finite values are allowed in 'lims'")
#Grid:
g<-grid(n,lims) #Function to create grid.
#The distance matrix gets large... Can we work around it? YES WE CAN!
sets<-ceiling(dim(g)[1]/10000)
#Allocate our output:
z<-rep(as.double(0),dim(g)[1])
for (i in (1:sets)-1) {
g_subset=g[(i*10000+1):(min((i+1)*10000,dim(g)[1])),]
a_matrix<-rdist.earth(g_subset,data,miles=FALSE)
z[(i*10000+1):(min((i+1)*10000,dim(g)[1]))]<- apply( #Here is my kernel...
a_matrix,1,FUN=function(X)
{sum(exp(-X^2/(2*(h^2))))/(2*pi*nx)}
)
rm(a_matrix)
}
print(Sys.time())
#Un-transpose the final data.
z<-t(matrix(z,n,n))
dim(z)<-c(n^2,1)
z<-as.vector(z)
return(z)
}
The key point here is that any kernel can be used in that inner loop; the downside is that this is evaluated at grid points, so a high-res grid is needed to run this; FFT would be great, but I didn't attempt it.
Grid Function:
grid<- function(n,lims) {
num <- rep(n, length.out = 2L)
gx <- seq.int(lims[1L], lims[2L], length.out = num[1L])
gy <- seq.int(lims[3L], lims[4L], length.out = num[2L])
v1=rep(gy,length(gx))
v2=rep(gx,length(gy))
v1<-matrix(v1, nrow=length(gy), ncol=length(gx))
v2<-t(matrix(v2, nrow=length(gx), ncol=length(gy)))
grid_out<-c(unlist(v1),unlist(v2))
grid_out<-aperm(array(grid_out,dim=c(n,n,2)),c(3,2,1) ) #reshape
grid_out<-unlist(as.list(grid_out))
dim(grid_out)<-c(2,n^2)
grid_out<-t(grid_out)
return(grid_out)
}
You can plot the values using image.plot, with the v1 and v2 matrices for your x,y points:
kde2d_mod_plot<-function(kde2d_mod_output,n,lims) ){
num <- rep(n, length.out = 2L)
gx <- seq.int(lims[1L], lims[2L], length.out = num[1L])
gy <- seq.int(lims[3L], lims[4L], length.out = num[2L])
v1=rep(gy,length(gx))
v2=rep(gx,length(gy))
v1<-matrix(v1, nrow=length(gy), ncol=length(gx))
v2<-t(matrix(v2, nrow=length(gx), ncol=length(gy)))
image.plot(v1,v2,matrix(kde2d_mod_output,n,n))
map('world', fill = FALSE,add=TRUE)
}

filling color gridient under normal curve in X direction in r

I am trying to shade under curve (contrast to y direction in this post). Just the following is hypothesis of filling direction.
curve(dnorm(x,0,1),xlim=c(-3,3),main='Standard Normal')
I am trying to write a function, where I can fill very small polygons with different colors ( I do not know if this is right approach), then it will look like gradient.
The idea is to extend the following filling of single polygon to n polygons.
codx <- c(-3,seq(-3,-2,0.01),-2)
cody <- c(0,dnorm(seq(-3,-2,0.01)),0)
curve(dnorm(x,0,1),xlim=c(-3,3),main='Standard Normal')
polygon(codx,cody,col='red')
I tried to extend it to a function:
x1 <- NULL
y1 <- NULL
polys <- function ( lwt, up, itn) {
x1 <- c(lwt,seq(lwt,up, itn),up)
y1 <- c(0,dnorm(seq(lwt,up,tn)),0)
out <- list (x1, y1)
return (out)
}
out <- polys(lwt = 0, up = 1, itn = 0.1)
library(RColorBrewer)
plotclr <- brewer.pal(10,"YlOrRd")
Neither I could workout the function nor I could brew more colors than 9 this way. Help appreciated.
You can use segments to achieve "roughly" what you want
x <- seq(from=-3, to=3,by=0.01)
curve(dnorm(x,0,1), xlim=c(-3,3))
segments(x, rep(0,length(x)),x,dnorm(x,0,1) , col=heat.colors(length(x)), lwd=2)

a fast way to calculate orthogonal distance of a point to y=x in R

I have a bunch of points that lie around y=x (see the examples below), and I hope to calculate the orthogonal distance of each point to this y=x. Suppose that a point has coordinates (a,b), then it's easy to see the projected point on the y=x has coordinates ((a+b)/2, (a+b)/2). I use the following native codes for the calculation, but I think I need a faster one without the for loops. Thank you very much!
set.seed(999)
n=50
typ.ord = seq(-2,3, length=n) # x-axis
#
good.ord = sort(c(rnorm(n/2, typ.ord[1:n/2]+1,0.1),rnorm(n/2,typ.ord[(n/2+1):n]-0.5,0.1)))
y.min = min(good.ord)
y.max = max(good.ord)
#
plot(typ.ord, good.ord, col="green", ylim=c(y.min, y.max))
abline(0,1, col="blue")
#
# a = typ.ord
# b = good.ord
cal.orth.dist = function(n, typ.ord, good.ord){
good.mid.pts = (typ.ord + good.ord)/2
orth.dist = numeric(n)
for (i in 1:n){
num.mat = rbind(rep(good.mid.pts[i],2), c(typ.ord[i], good.ord[i]))
orth.dist[i] = dist(num.mat)
}
return(orth.dist)
}
good.dist = cal.orth.dist(50, typ.ord, good.ord)
sum(good.dist)
As easy as
good.dist <- sqrt((good.ord - typ.ord)^2 / 2)
It all boils down to compute the distance between a point and a line. In the 2D case of y = x, this becomes particularly easy (try it yourself).
In the more general case (extending to other lines in possibly more than 2-D space), you can use the following. It works by constructing a projection matrix P from the subspace (here the vector A) onto which you want to project the points x. Subtracting the projected component from the points leaves the orthogonal component, for which it's easy to calculate the distances.
x <- cbind(typ.ord, good.ord) # Points to be projected
A <- c(1,1) # Subspace to project onto
P <- A %*% solve(t(A) %*% A) %*% t(A) # Projection matrix P_A = A (A^T A)^-1 A^T
dists <- sqrt(rowSums(x - x %*% P)^2) # Lengths of orthogonal residuals

Generating multidimensional data

Does R have a package for generating random numbers in multi-dimensional space? For example, suppose I want to generate 1000 points inside a cuboid or a sphere.
I have some functions for hypercube and n-sphere selection that generate dataframes with cartesian coordinates and guarantee a uniform distribution through the hypercube or n-sphere for an arbitrary amount of dimensions :
GenerateCubiclePoints <- function(nrPoints,nrDim,center=rep(0,nrDim),l=1){
x <- matrix(runif(nrPoints*nrDim,-1,1),ncol=nrDim)
x <- as.data.frame(
t(apply(x*(l/2),1,'+',center))
)
names(x) <- make.names(seq_len(nrDim))
x
}
is in a cube/hypercube of nrDim dimensions with a center and l the length of one side.
For an n-sphere with nrDim dimensions, you can do something similar, where r is the radius :
GenerateSpherePoints <- function(nrPoints,nrDim,center=rep(0,nrDim),r=1){
#generate the polar coordinates!
x <- matrix(runif(nrPoints*nrDim,-pi,pi),ncol=nrDim)
x[,nrDim] <- x[,nrDim]/2
#recalculate them to cartesians
sin.x <- sin(x)
cos.x <- cos(x)
cos.x[,nrDim] <- 1 # see the formula for n.spheres
y <- sapply(1:nrDim, function(i){
if(i==1){
cos.x[,1]
} else {
cos.x[,i]*apply(sin.x[,1:(i-1),drop=F],1,prod)
}
})*sqrt(runif(nrPoints,0,r^2))
y <- as.data.frame(
t(apply(y,1,'+',center))
)
names(y) <- make.names(seq_len(nrDim))
y
}
in 2 dimensions, these give :
From code :
T1 <- GenerateCubiclePoints(10000,2,c(4,3),5)
T2 <- GenerateSpherePoints(10000,2,c(-5,3),2)
op <- par(mfrow=c(1,2))
plot(T1)
plot(T2)
par(op)
Also check out the copula package. This will generate data within a cube/hypercube with uniform margins, but with correlation structures that you set. The generated variables can then be transformed to represent other shapes, but still with relations other than independent.
If you want more complex shapes but are happy with uniform and idependent within the shape then you can just do rejection sampling: generate data within a cube that contains your shape, then test if the points are within your shape, reject them if not, then keep doing this until there are enough points.
A couple of years ago, I made a package called geozoo. It is available on CRAN.
install.packages("geozoo")
library(geozoo)
It has many different functions to produce objects in N-dimensions.
p = 4
n = 1000
# Cube with points on it's face.
# A 3D version would be a box with solid walls and a hollow interior.
cube.face(p)
# Hollow sphere
sphere.hollow(p, n)
# Solid cube
cube.solid.random(p, n)
cube.solid.grid(p, 10) # evenly spaced points
# Solid Sphere
sphere.solid.random(p, n)
sphere.solid.grid(p, 10) # evenly spaced points
One of my favorite ones to watch animate is a cube with points along its edges, because it was one of the first objects that I made. It also gives you a sense of distance between vertices.
# Cube with points along it's edges.
cube.dotline(4)
Also, check out the website: http://streaming.stat.iastate.edu/~dicook/geometric-data/. It contains pictures and downloadable data sets.
Hope it meets your needs!
Cuboid:
df <- data.frame(
x = runif(1000),
y = runif(1000),
z = runif(1000)
)
head(df)
x y z
1 0.7522104 0.579833314 0.7878651
2 0.2846864 0.520284731 0.8435828
3 0.2240340 0.001686003 0.2143208
4 0.4933712 0.250840233 0.4618258
5 0.6749785 0.298335804 0.4494820
6 0.7089414 0.141114804 0.3772317
Sphere:
df <- data.frame(
radius = runif(1000),
inclination = 2*pi*runif(1000),
azimuth = 2*pi*runif(1000)
)
head(df)
radius inclination azimuth
1 0.1233281 5.363530 1.747377
2 0.1872865 5.309806 4.933985
3 0.2371039 5.029894 6.160549
4 0.2438854 2.962975 2.862862
5 0.5300013 3.340892 1.647043
6 0.6972793 4.777056 2.381325
Note: edited to include code for sphere
Here is one way to do it.
Say we hope to generate a bunch of 3d points of the form y = (y_1, y_2, y_3)
Sample X from multivariate Gaussian with mean zero and covariance matrix R.
(x_1, x_2, x_3) ~ Multivariate_Gaussian(u = [0,0,0], R = [[r_11, r_12, r_13],r_21, r_22, r_23], [r_31, r_32, r_33]]
You can find a function which generates Multivariate Gaussian samples in an R package.
Take the Gaussian cdf of each covariate (phi(x_1) , phi(x_2), phi(x_3)). In this case, phi is the Gaussian cdf of our variables. Ie phi(x_1) = Pr[x <= x_1] By the probability integral transform, these (phi(x_1) , phi(x_2), phi(x_3)) = (u_1, u_2, u_3), will each be uniformly distrubted on [0,1].
Then, take the inverse cdf of each uniformly distributed marginal. In other words take the inverse cdf of u_1, u_2, u_3:
F^{-1}(u_1), F^{-2}(u_2), F^{-3}(u_3) = (y_1, y_2, y_3), where F is the marginal cdf of the distrubution you are trying to sample from.

Resources