I want to plot a partition of a two-dimensional covariate space constructed by recursive binary splitting. To be more precise, I would like to write a function that replicates the following graph (taken from Elements of Statistical Learning, pag. 306):
Displayed above is a two-dimensional covariate space and a partition obtained by recursive binary splitting the space using axis-aligned splits (what is also called a CART algorithm). What I want to implement is a function that takes the output of the rpart function and generates such plot.
It follows some example code:
## Generating data.
set.seed(1975)
n <- 5000
p <- 2
X <- matrix(sample(seq(0, 1, by = 0.01), n * p, replace = TRUE), ncol = p)
Y <- X[, 1] + 2 * X[, 2] + rnorm(n)
## Building tree.
tree <- rpart(Y ~ ., data = data.frame(Y, X), method = "anova", control = rpart.control(cp = 0, maxdepth = 2))
Navigating SO I found this function:
rpart_splits <- function(fit, digits = getOption("digits")) {
splits <- fit$splits
if (!is.null(splits)) {
ff <- fit$frame
is.leaf <- ff$var == "<leaf>"
n <- nrow(splits)
nn <- ff$ncompete + ff$nsurrogate + !is.leaf
ix <- cumsum(c(1L, nn))
ix_prim <- unlist(mapply(ix, ix + c(ff$ncompete, 0), FUN = seq, SIMPLIFY = F))
type <- rep.int("surrogate", n)
type[ix_prim[ix_prim <= n]] <- "primary"
type[ix[ix <= n]] <- "main"
left <- character(nrow(splits))
side <- splits[, 2L]
for (i in seq_along(left)) {
left[i] <- if (side[i] == -1L)
paste("<", format(signif(splits[i, 4L], digits)))
else if (side[i] == 1L)
paste(">=", format(signif(splits[i, 4L], digits)))
else {
catside <- fit$csplit[splits[i, 4L], 1:side[i]]
paste(c("L", "-", "R")[catside], collapse = "", sep = "")
}
}
cbind(data.frame(var = rownames(splits),
type = type,
node = rep(as.integer(row.names(ff)), times = nn),
ix = rep(seq_len(nrow(ff)), nn),
left = left),
as.data.frame(splits, row.names = F))
}
}
Using this function, I am able to recover all the splitting variables and points:
splits <- rpart_splits(tree)[rpart_splits(tree)$type == "main", ]
splits
# var type node ix left count ncat improve index adj
# 1 X2 main 1 1 < 0.565 5000 -1 0.18110662 0.565 0
# 3 X2 main 2 2 < 0.265 2814 -1 0.06358597 0.265 0
# 6 X1 main 3 5 < 0.645 2186 -1 0.07645851 0.645 0
The column var tells me the splitting variables for each non-terminal node, and the column left tells the associated splitting points. However, I do not know how to use this information to produce my desired plots.
Of course if you have any alternative strategy that do not involve the use of rpart_splits feel free to suggest it.
You could use the (unpublished) parttree package, which you can install from GitHub via:
remotes::install_github("grantmcdermott/parttree")
This allows:
library(parttree)
ggplot() +
geom_parttree(data = tree, aes(fill = path)) +
coord_cartesian(xlim = c(0, 1), ylim = c(0, 1)) +
scale_fill_brewer(palette = "Pastel1", name = "Partitions") +
theme_bw(base_size = 16) +
labs(x = "X2", y = "X1")
Incidentally, this package also contains the function parttree, which returns something very similar to your
rpart_splits function:
parttree(tree)
node Y path xmin xmax ymin ymax
1 4 0.7556079 X2 < 0.565 --> X2 < 0.265 -Inf 0.265 -Inf Inf
2 5 1.3087679 X2 < 0.565 --> X2 >= 0.265 0.265 0.565 -Inf Inf
3 6 1.8681143 X2 >= 0.565 --> X1 < 0.645 0.565 Inf -Inf 0.645
4 7 2.4993361 X2 >= 0.565 --> X1 >= 0.645 0.565 Inf 0.645 Inf
I have a set of 3D-Bodies. Each Body is defined by 8 points with three coordinates each. All of the bodies are cubical or approximately cubical. I would like to "fill" the cubes with a systematic point raster. The coordinates are stored in simple data.frames.
I developed the following code that does what I want for cubical bodies:
# libraries
library(rgl)
# define example cube with 8 points
excube <- data.frame(
x = c(1,1,1,1,5,5,5,5),
y = c(1,1,4,4,1,1,4,4),
z = c(4,8,4,8,4,8,4,8)
)
# cubeconst: fill cube (defined by 8 corner points) with a 3D-point-raster
cubeconst <- function(x, y, z, res) {
cube <- data.frame()
xvec = seq(min(x), max(x), res)
yvec = seq(min(y), max(y), res)
zvec = seq(min(z), max(z), res)
for (xpoint in 1:length(xvec)) {
for (ypoint in 1:length(yvec)) {
for (zpoint in 1:length(zvec)) {
cube <- rbind(cube, c(xvec[xpoint], yvec[ypoint], zvec[zpoint]))
}
}
}
colnames(cube) <- c("x", "y", "z")
return(cube)
}
# apply cubeconst to excube
fcube <- cubeconst(x = excube$x, y = excube$y, z = excube$z, res = 0.5)
# plot result
plot3d(
fcube$x,
fcube$y,
fcube$z,
type = "p",
xlab = "x",
ylab = "y",
zlab = "z"
)
Now I'm searching for a solution to "fill" approximately cubical bodies like for example the following body:
# badcube
badcube <- data.frame(
x = c(1,1,1,1,5,5,5,5),
y = c(1,1,4,4,1,1,4,4),
z = c(4,10,4,12,4,8,4,8)
)
# plot badcube
plot3d(
badcube$x,
badcube$y,
badcube$z,
col = "red",
size = 10,
type = "p",
xlab = "x",
ylab = "y",
zlab = "z"
)
Maybe you can point me in the right direction.
You need to transform the hexahedron (wonky cube) to a unit cube. The following image shows what I mean, and gives us a numbering scheme for the vertices of the hexa. Vertex 2 is hidden behind the cube.
The transformation is from real space x,y,z, to a new coordinate system u,v,w, in which the hexa is a unit cube. The typical function used for hexa looks like this.
x = A + B*u + C*v + D*w + E*u*v + F*u*w + G*v*w + H*u*v*w
Transformations for y and z coordinates are of the same form. You have 8 corners to your cube, so you can substitute these in to solve for coefficients A,B,.... The unit coordinates u,v,w are either 0 or 1 at every vertex, so this simplifies things a lot.
x0 = A // everything = zero
x1 = A + B // u = 1, others = zero
x2 = A + C // v = 1, ...
x4 = A + D // w = 1
x3 = A + B + C + E // u = v = 1
x5 = A + B + D + F // u = w = 1
x6 = A + C + D + G // v = w = 1
x7 = A + B + C + D + E + F + G + H // everything = 1
You then have to solve for A,B,.... This is easy because you just forward substitute. A equals x0. B equals x1 - A, etc... You have to do this for y and z also, but if your language supports vector operations, this can probably be done in the same step as for x.
Once you have the coefficients, you can convert a point u,v,w to x,y,z. Now, if you have a point generation scheme which works on a 1x1x1 cube, you can transform the result to the origonal hex. You could retain the same triple-loop structure in your posted code, and vary u,v,w between 0 and 1 to create a grid of points within the hex.
I'm afraid I don't know r, so I can't give you any example code in that language. Here's a quick python3 example, though, just to prove it works.
import matplotlib.pyplot as pp
import numpy as np
from mpl_toolkits.mplot3d import Axes3D
np.random.seed(0)
cube = np.array([
[0.0, 0.0, 0.0], [1.0, 0.0, 0.0], [0.0, 1.0, 0.0], [1.0, 1.0, 0.0],
[0.0, 0.0, 1.0], [1.0, 0.0, 1.0], [0.0, 1.0, 1.0], [1.0, 1.0, 1.0]])
hexa = cube + 0.5*np.random.random(cube.shape)
edges = np.array([
[0, 1], [0, 2], [1, 3], [2, 3],
[0, 4], [1, 5], [2, 6], [3, 7],
[4, 5], [4, 6], [5, 7], [6, 7]])
def cubeToHexa(hexa, u, v, w):
A = hexa[0]
B = hexa[1] - A
C = hexa[2] - A
D = hexa[4] - A
E = hexa[3] - A - B - C
F = hexa[5] - A - B - D
G = hexa[6] - A - C - D
H = hexa[7] - A - B - C - D - E - F - G
xyz = (
A +
B*u[...,np.newaxis] +
C*v[...,np.newaxis] +
D*w[...,np.newaxis] +
E*u[...,np.newaxis]*v[...,np.newaxis] +
F*u[...,np.newaxis]*w[...,np.newaxis] +
G*v[...,np.newaxis]*w[...,np.newaxis] +
H*u[...,np.newaxis]*v[...,np.newaxis]*w[...,np.newaxis])
return xyz[...,0], xyz[...,1], xyz[...,2]
fg = pp.figure()
ax = fg.add_subplot(111, projection='3d')
temp = np.reshape(np.append(hexa[edges], np.nan*np.ones((12,1,3)), axis=1), (36,3))
ax.plot(temp[:,0], temp[:,1], temp[:,2], 'o-')
u, v, w = np.meshgrid(*[np.linspace(0, 1, 6)]*3)
x, y, z = cubeToHexa(hexa, u, v, w)
ax.plot(x.flatten(), y.flatten(), z.flatten(), 'o')
pp.show()
I can't recall the exact justificiation for this form of the transformation. It's certainly easy to solve, and it has no squared terms, so lines in the directions of the u,v,w axes map to straight lines in x,y,z. This means your cube edges and faces are guaranteed to conform, as well as the corners. I lack the maths to prove it, though, and I couldn't find any googleable information either. My knowledge comes from a distant memory of textbooks on Finite Element Methods, where these sort of transformations are common. If you need more information, I suggest you start looking there.
Thanks to Bills explanation and examples I was able to come up with the following solution in R:
# libraries
library(rgl)
# create heavily distorted cube - hexahedron
hexatest <- data.frame(
x = c(0,1,0,4,5,5,5,5),
y = c(1,1,4,4,1,1,4,4),
z = c(4,8,4,9,4,8,4,6)
)
# cubetohexa: Fills hexahedrons with a systematic point raster
cubetohexa <- function(hexa, res){
# create new coordinate system (u,v,w)
resvec <- seq(0, 1, res)
lres <- length(resvec)
u <- c()
for (p1 in 1:lres) {
u2 <- c()
for (p2 in 1:lres) {
u2 <- c(u2, rep(resvec[p2], lres))
}
u <- c(u,u2)
}
v <- c()
for (p1 in 1:lres) {
v <- c(v, rep(resvec[p1], lres^2))
}
w <- rep(resvec, lres^2)
# transformation
A <- as.numeric(hexa[1,])
B <- as.numeric(hexa[2,]) - A
C <- as.numeric(hexa[3,]) - A
D <- as.numeric(hexa[5,]) - A
E <- as.numeric(hexa[4,]) - A - B - C
F <- as.numeric(hexa[6,]) - A - B - D
G <- as.numeric(hexa[7,]) - A - C - D
H <- as.numeric(hexa[8,]) - A - B - C - D - E - F - G
A <- matrix(A, ncol = 3, nrow = lres^3, byrow = TRUE)
B <- matrix(B, ncol = 3, nrow = lres^3, byrow = TRUE)
C <- matrix(C, ncol = 3, nrow = lres^3, byrow = TRUE)
D <- matrix(D, ncol = 3, nrow = lres^3, byrow = TRUE)
E <- matrix(E, ncol = 3, nrow = lres^3, byrow = TRUE)
F <- matrix(F, ncol = 3, nrow = lres^3, byrow = TRUE)
G <- matrix(G, ncol = 3, nrow = lres^3, byrow = TRUE)
H <- matrix(H, ncol = 3, nrow = lres^3, byrow = TRUE)
for (i in 1:(lres^3)) {
B[i,] <- B[i,] * u[i]
C[i,] <- C[i,] * v[i]
D[i,] <- D[i,] * w[i]
E[i,] <- E[i,] * u[i] * v[i]
F[i,] <- F[i,] * u[i] * w[i]
G[i,] <- G[i,] * v[i] * w[i]
H[i,] <- H[i,] * u[i] * v[i] * w[i]
}
m <- data.frame(A+B+C+D+E+F+G+H)
colnames(m) <- c("x", "y", "z")
# output
return(m)
}
# apply cubetohexa to hexatest
cx <- cubetohexa(hexatest, 0.1)
# plot result
plot3d(
cx$x,
cx$y,
cx$z,
type = "p",
xlab = "x",
ylab = "y",
zlab = "z"
)
Edit:
This function is now implemented with Rcpp in my R package recexcavAAR.
Given two Gaussian density curves, how do I identify 'v', such that 'v' equally separate area under overlap?
The following code will create the visualisation of my problem. I am interested in calculating the area 'A' and then find the x-value 'v', which exactly splits the area in two?
# Define Gaussian parameters
mu1 = 10
sd1 = 0.9
mu2 = 12
sd2 = 0.6
# Visualise, set values
sprd = 3
xmin = min(c(mu1-sprd*sd1,mu2-sprd*sd2))
xmax = max(c(mu1+sprd*sd1,mu2+sprd*sd2))
x = seq(xmin,xmax,length.out=1000)
y1 = dnorm(x,mean=mu1,sd=sd1)
y2 = dnorm(x,mean=mu2,sd=sd2)
ymin = min(c(y1,y2))
ymax = max(c(y1,y2))
# Visualise, plot
plot(x,y1,xlim=c(xmin,xmax),ylim=c(ymin,ymax),type="l",col=2,ylab="Density(x)")
lines(x,y2,col=3)
abline(v=c(mu1,mu2),lty=2,col=c(2,3))
abline(h=0,lty=2)
legend("topleft",legend=c("N(mu1,sd1)","N(mu2,sd2)","mu1","mu2"),lty=c(1,1,2,2),col=c(2,3))
text(11,0.05,"A",cex=2)
Based on the comments on this post, I have written I have written my own proposal for a solution:
gaussIsect = function(mu1,mu2,sd1,sd2){
sd12 = sd1**2
sd22 = sd2**2
sqdi = sd12-sd22
x1 = (mu2 * sd12 - sd2*( mu1*sd2 + sd1*sqrt( (mu1-mu2)**2 + 2*sqdi * log(sd1/sd2) ) )) / sqdi
x2 = (mu2 * sd12 - sd2*( mu1*sd2 - sd1*sqrt( (mu1-mu2)**2 + 2*sqdi * log(sd1/sd2) ) )) / sqdi
return(c(x1,x2))
}
gaussSplitOlap = function(mu1,mu2,sd1,sd2){
if( mu1 > mu2 ){
tmp = c(mu1,mu2)
mu1 = tmp[2]
mu2 = tmp[1]
tmp = c(sd1,sd2)
sd1 = tmp[2]
sd2 = tmp[1]
}
isct = gaussIsect(mu1=mu1,mu2=mu2,sd1=sd1,sd2=sd2)
isct = isct[which(mu1 < isct & isct < mu2)]
a1 = 1-pnorm(isct,mean=mu1,sd=sd1)
a2 = pnorm(isct,mean=mu2,sd=sd2)
A = a1 + a2
v1 = qnorm(1-A/2,mean=mu1,sd=sd1)
v2 = qnorm(A/2,mean=mu2,sd=sd2)
results = list(isct=isct,A=A,v1=v1,v2=v2)
return(results)
}
test = gaussSplitOlap(mu1 = 10,sd1 = 0.9,mu2 = 12,sd2 = 0.6)
print(test)
The output from running this test is as follows
$isct
[1] 11.09291
$A
[1] 0.1775984
$v1
[1] 11.21337
$v2
[1] 11.19109
I would have assumed that the v1and v2 values were equal?
First solve analitycally the problem of finding the point x where it overlaps (this is deg 2 polynomial equation).
Then given this x the area is the sum of the two tails:
area = min(pnorm(x, mean = mu1, sd = sd1), 1 - pnorm(x, mean = mu1, sd = sd1)) +
min(pnorm(x, mean = mu2, sd = sd2), 1 - pnorm(x, mean = mu2, sd = sd2))
Like I said in the comment, you can to this using simple Monte Carlo simulation:
prob<-c()
med<-c()
for(i in 1:1000){
randomX<-runif(1000000,xmin,xmax)
randomY<-runif(1000000,0,0.3)
cond<-(randomY<dnorm(randomX,mean=mu1,sd=sd1) & randomY<dnorm(randomX,mean=mu2,sd=sd2))
prob<-c(prob,sum(cond)/1000000*(xmax-xmin)*0.3)
med<-c(med,median(randomX[which(cond==1)]))
}
cat("Area of A is equal to: ", mean(prob),"\n")
# Area of A is equal to: 0.1778459
cat("Value of v is equal to: ",mean(med),"\n")
# Value of v is equal to: 11.21008
plot(x,y1,xlim=c(xmin,xmax),ylim=c(ymin,ymax),type="l",col=2,ylab="Density(x)")
lines(x,y2,col=3)
abline(v=c(mu1,mu2,mean(med)),lty=2,col=c(2,3,4))
abline(h=0,lty=2)
legend("topleft",legend=c("N(mu1,sd1)","N(mu2,sd2)","mu1","mu2"),lty=c(1,1,2,2),col=c(2,3))
text(11,0.05,"A",cex=2)