3D Biplot in plotly - R - r

I want to build a 3D PCA bi-plot using plotly package because the graph is nice and interactive in html format (something that I need).
My difficulty is to add the loading. I want the loading to be presented as straight lines from the point (0,0,0) (i.e. the equivalent to 2D biplots)
So all in all I don't know how to add straight lines starting from the centre of the 3D graph.
I have calculated the scores and loading using the PCA function;
pca1 <- PCA (dat1, graph = F)
for scores:
ind1 <- pca1$ind$coord[,1:3]
x <- ind1[,1] ; y <- ind1[,2] ; z <- ind1[,3]
for loadings:
var1 <- pca1$var$coord[,1:3]
xl <- var1[,1] ; yl <- var1[,2] ; zl <- var1[,3]
and using the code bellow the 3D score plot is generated;
p <- plot_ly( x=x, y=y, z=z,
marker = list(opacity = 0.7, color=y , colorscale = c('#FFE1A1', '#683531'), showscale = F)) %>%
layout(title = "3D Prefmap",
scene = list(
xaxis = list(title = "PC 1"),
yaxis = list(title = "PC 2"),
zaxis = list(title = "PC 3")))

Here are some ideas that could be useful for the development of a 3D biplot.
# Data generating process
library(MASS)
set.seed(6543)
n <- 500
mu <- c(1,-2,3,-1,3,4)
Sigma <- diag(rep(1,length(mu)))
Sigma[3,1] <- Sigma[1,3] <- 0.1
Sigma[4,6] <- Sigma[6,4] <- 0.1
X <- as.data.frame(mvrnorm(n, mu=mu, Sigma=Sigma))
# PCA
pca <- princomp(X, scores=T, cor=T)
# Scores
scores <- pca$scores
x <- scores[,1]
y <- scores[,2]
z <- scores[,3]
# Loadings
loads <- pca$loadings
# Scale factor for loadings
scale.loads <- 5
# 3D plot
library(plotly)
p <- plot_ly() %>%
add_trace(x=x, y=y, z=z,
type="scatter3d", mode="markers",
marker = list(color=y,
colorscale = c("#FFE1A1", "#683531"),
opacity = 0.7))
for (k in 1:nrow(loads)) {
x <- c(0, loads[k,1])*scale.loads
y <- c(0, loads[k,2])*scale.loads
z <- c(0, loads[k,3])*scale.loads
p <- p %>% add_trace(x=x, y=y, z=z,
type="scatter3d", mode="lines",
line = list(width=8),
opacity = 1)
}
print(p)

Related

Surface of a matrix with plotly in R distorted

I have the following code example in R to visualize a surface generated as an interpolation from points.
library(plotly)
test_data=read.csv("test_data.csv")
x<- test_data$x
y<- test_data$y
z<- test_data$z
fit_loess=loess(z ~ x + y , degree = 0,span=0.54)
min_x <- min(x)
max_x <- max(x)
min_y <- min(y)
max_y <- max(y)
griddf <- expand.grid(x = (seq(min_x,max_x,length.out = 10)),
y = (seq(min_y,max_y,length.out = 10)))
p_loess <- data.frame(griddf)
p_loess$z <- predict(fit_loess, p_loess)
fig <- plot_ly()
fig <- fig %>% add_surface(z = ~xtabs(z ~ x + y, data = p_loess),
x = seq(min_x,max_x,length.out = 10),
y =seq(min_y,max_y,length.out = 10),colorbar=list(title = 'z'))
fig <- fig %>% add_markers( x = ~x, y = ~y, z = ~z,
marker = list(color = 'rgb(17, 157, 255)',size = 3))
fig
According my question in Question ID 73946202 , I am using xtabs for matrix generation.
But the result of the surface of plotly is distorted to the measurement points. I am not able to find the reason for that.
test_data.csv:
"","x","y","z"
"1",1.97494896,9.99449486,54.9318
"2",1.97493756666667,9.9945128,54.970222222222
"3",1.97492473333333,9.9945292333333,55.060666666667
"4",1.97491141666667,9.9945450333333,55.415
"5",1.97489883333333,9.9945608833333,55.639666666667
"6",1.97488585,9.99457735,55.742166666667
"7",1.97487323333333,9.9945934166667,55.772333333333
"8",1.97486086666667,9.9946095833333,55.953333333333
"9",1.97485151666667,9.99462525,55.970166666667
"10",1.97483576666667,9.9946413166667,56.0495
"11",1.97506965,9.9945288666667,55.070333333333
"12",1.9750572,9.99454545,55.196666666667
"13",1.97504416666667,9.9945614,55.305
"14",1.97503078333333,9.9945772833333,55.375166666667
"15",1.97501828333333,9.9945933333333,55.5
"16",1.97500516666667,9.9946096666667,55.615333333333
"17",1.97499288333334,9.9946255833333,55.725
"18",1.97498116666667,9.9946405166667,55.766333333333
"19",1.97496823333333,9.9946565833333,55.781333333333
"20",1.97495426666667,9.9946739166667,56.014333333333

Plot 3d plane from x+y+z=6 equation in plotly

I have a set of equations (z1) x+y+z=6, (z2) x+2y+2z=9 and (z3) x+3y+4z=13 and would like to plot the planes using plotly.
Method1: using mesh3d
require(plotly)
x<-seq(from=-10, to=10, by=1)
y<-seq(from=-10, to=10, by=1)
z1<-6-x-y #For the first plane
fig <- plot_ly(x = ~, y = ~y, z = ~z1, type = 'mesh3d')
fig
Produces no output though. Why?
Method 2: Using surface
Whereas this produces a plane but the wrong one.
library(plotly)
x<-seq(from=-10,to=10,by=1)
y<-seq(from=-10,to=10,by=1)
z1<-6-x-y
z1<-matrix(rep(z1,10),NROW(x),10)
fig <- plot_ly(showscale = FALSE)
fig <- fig %>% add_surface(z = ~z1)
fig
This plane is not correct. If you look at the point x=2, y=2, z should equal 2 but it doesn't. Instead it is 22, and that's not correct.
When x <- seq(from=-10, to=10, by=1); y<-seq(from=-10, to=10, by=1), x+y+z=6 is not plane but line.
You need to prepare more data points.
library(dplyr); library(tidyr); library(plotly)
x <- seq(from=-10, to=10, by=1)
y <- seq(from=-10, to=10, by=1)
z1 <- 6-x-y #For the first plane
origin <- tibble(x = x, y = y, z = z1)
# prepare all combination of x and y, and calculate z1
xyz1 <- tidyr::crossing(x, y) %>%
mutate(z1 = 6-x-y)
plot_ly(x = ~x, y = ~y, z = ~z1, type = "mesh3d", data = xyz1) %>%
add_markers(~ x, ~y, ~z1, data = origin)
Orange points are the data you prepare (when x <- seq(from=-10, to=10, by=1); y<-seq(from=-10, to=10, by=1) , x+y+z=6 is line.)

Add regression plane in R using Plotly

I recently tried to plot a regression pane in RStudio using the plotly library and read this post: Add Regression Plane to 3d Scatter Plot in Plotly
I followed the exact same procedure and ended up with a regression plane, which is obviously not correct:
EDIT: I followed the proposal in the first answer and my result looks like this:
Here is my code, I commented every step: sm is the data.frame I used
library(reshape2);
sm <- read.delim("Supermodel.dat", header = TRUE);
x1 <- sm$age
x2 <- sm$years
y <- sm$salary
df <- data.frame(x1, x2, y);
### Estimation of the regression plane
mod <- lm(y ~ x1+x2, data = df, na.action =
na.omit);
cf.mod <- coef(mod)
### Calculate z on a grid of x-y values
x1.seq <- seq(min(x1),max(x1),length.out=231)
x2.seq <- seq(min(x2),max(x2),length.out=231)
z.mtx <- t(outer(x1.seq, x2.seq, function(x1,x2)
cf.mod[1]+cf.mod[2]*x1+cf.mod[3]*x2))
#### Draw the plane with "plot_ly" and add points with "add_trace"
library(plotly)
# Draw plane with plotly surface plot
plane <- plot_ly(x=~x1.seq, y=~x2.seq, z=~z.mtx, colors =
c("#f5cb11", #b31d83"),type="surface") %>%
add_trace(data=df, x=x1, y=x2, z=y, mode="markers",
type="scatter3d",
marker = list(color="black", opacity=0.7, symbol=105)) %>%
layout(scene = list(aspectmode = "manual", aspectratio = list(x=1,
y=1, z=1), xaxis = list(title = "Age", range = c(12,24)), yaxis =
list(title = "Work experience (years)", range = c(0,10)), zaxis =
list(title = "Salary p.a. (k)", range = c(0,90) )))
plane
I checked with the str-function, if the x1.seq and x2.seq have the same number of entries, and they both have 231 number values in them. The plane gets calculated and is shown, but it obviously still wrong.
PS: If you want to run the code, just download the file Supermodel.dat from Andy Fields website (https://studysites.uk.sagepub.com/dsur/study/articles.htm) under Regression.
Thanks in advance,
rikojir
Here is an illustrative example that shows how the observed points and the regression plane can be plotted together in a 3D plot generated using the plotlty package.
Hope it can help you.
### Data generating process
set.seed(1234)
n <- 50
x1 <- runif(n); x2 <- runif(n)
x3 <- rnorm(n)>0.5
y <- 2*x1-x2+rnorm(n, sd=0.25)
df <- data.frame(y, x1, x2, x3)
### Estimation of the regression plane
mod <- lm(y ~ x1+x2)
cf.mod <- coef(mod)
### Calculate z on a grid of x-y values
x1.seq <- seq(min(x1),max(x1),length.out=25)
x2.seq <- seq(min(x2),max(x2),length.out=25)
z <- t(outer(x1.seq, x2.seq, function(x,y) cf.mod[1]+cf.mod[2]*x+cf.mod[3]*y))
#### Draw the plane with "plot_ly" and add points with "add_trace"
cols <- c("#f5cb11", "#b31d83")
cols <- cols[x3+1]
library(plotly)
p <- plot_ly(x=~x1.seq, y=~x2.seq, z=~z,
colors = c("#f5cb11", "#b31d83"),type="surface") %>%
add_trace(data=df, x=x1, y=x2, z=y, mode="markers", type="scatter3d",
marker = list(color=cols, opacity=0.7, symbol=105)) %>%
layout(scene = list(
aspectmode = "manual", aspectratio = list(x=1, y=1, z=1),
xaxis = list(title = "X1", range = c(0,1)),
yaxis = list(title = "X2", range = c(0,1)),
zaxis = list(title = "Y", range = pretty(z)[c(1,8)])))
print(p)
Here is the 3D plot generated by the above code:

3d graph with contours lines

How add the contours under the graph using the R as in plot 2?
I've searched a lot on the internet and found no example of how to do it in R! Is there any function or package to add the outline along with the chart?
#Function density probability
library(pbivnorm)
bsb <- function(t1,t2){
a1 <- sqrt(phi1/2)*(sqrt(((phi1+1)*t1)/(phi1*mu1))-sqrt(((phi1*mu1)/((phi1+1)*t1))))
a2 <- sqrt(phi2/2)*(sqrt(((phi2+1)*t2)/(phi2*mu2))-sqrt(((phi2*mu2)/((phi2+1)*t2))))
Phi2 <- pbivnorm(a1, a2, rho, recycle = TRUE)
b1 <- ((phi1+1)/(2*phi1*mu1))*sqrt(phi1/2)*(((phi1*mu1)/((phi1+1)*t1))^(1/2)+((phi1*mu1)/((phi1+1)*t1))^(3/2))
b2 <- ((phi2+1)/(2*phi2*mu2))*sqrt(phi2/2)*(((phi2*mu2)/((phi2+1)*t2))^(1/2)+((phi2*mu2)/((phi2+1)*t2))^(3/2))
fdp <- Phi2*b1*b2
return(fdp)
}
t1 <- seq(0.001,5,length=100)
t2 <- seq(0.001,5,length=100)
#Parameters
mu1=5
phi1=2
mu2=5
phi2=2
rho=0.9
z<-outer(t1,t2,bsb) # calculate density values
persp(t1, t2, z, # 3-D plot
main="Bivariate Birnbaum-Saunders",
col="lightgray",
theta=40, phi=10,
r=10,
d=0.9,
expand=0.5,
ltheta=90, lphi=80,
shade=0.9,
ticktype="detailed",
nticks=5)
As #alistaire pointed out, it actually requires a single line to get the plotly version, see for documentation to edit details of the plot (https://plot.ly/r/3d-surface-plots/)
test<-outer(t1,t2,bsb) # your output matrix
p <- plot_ly(z = ~test) %>% add_surface()
p
Resolved:
source("https://raw.githubusercontent.com/walmes/wzRfun/master/R/panel.3d.contour.R")
library(lattice)
library(manipulate)
library(colorRamps)
#Function density probability
library(pbivnorm)
bsb <- function(t1,t2){
a1 <- sqrt(phi1/2)*(sqrt(((phi1+1)*t1)/(phi1*mu1))-sqrt(((phi1*mu1)/((phi1+1)*t1))))
a2 <- sqrt(phi2/2)*(sqrt(((phi2+1)*t2)/(phi2*mu2))-sqrt(((phi2*mu2)/((phi2+1)*t2))))
Phi2 <- pbivnorm(a1, a2, rho, recycle = TRUE)
b1 <- ((phi1+1)/(2*phi1*mu1))*sqrt(phi1/2)*(((phi1*mu1)/((phi1+1)*t1))^(1/2)+((phi1*mu1)/((phi1+1)*t1))^(3/2))
b2 <- ((phi2+1)/(2*phi2*mu2))*sqrt(phi2/2)*(((phi2*mu2)/((phi2+1)*t2))^(1/2)+((phi2*mu2)/((phi2+1)*t2))^(3/2))
fdp <- Phi2*b1*b2
return(fdp)
}
#Parameters
mu1=5
phi1=2
mu2=5
phi2=2
rho=0.9
grid <- expand.grid(t1 = seq(0.001,8, by = 0.1),
t2 = seq(0.001,8, by = 0.1))
grid$z <- bsb(grid$t1,grid$t2)
manipulate({
## Makes the three-dimensional chart
colr <- colorRampPalette(c(c1, c2, c3), space="rgb")
arrows <- arr
wireframe(z ~ t1 + t2,
data = grid,
scales = list(arrows = FALSE),
zlim = extendrange(grid$z, f = 0.25),
panel.3d.wireframe = "panel.3d.contour",
nlevels = 8,
col = "gray40",
type = c("bottom"),
col.regions = colr(101),
drape = TRUE, colorkey=FALSE,
screen=list(z=z.angle, x=x.angle),
axis.line = list(col = "transparent"),
clip = list(panel = "off"),
par.settings = list(box.3d = list(col=c(1,NA,NA,1,1,NA,NA,NA,NA))))
},
## Controls the value of angles and colors
z.angle=slider(0, 360, step=10, initial=40),
x.angle=slider(-180, 0, step=5, initial=-80),
arr=checkbox(FALSE, "show.arrows"),
c1=picker("transparent","black","red","yellow","orange","green","blue","pink","violet"),
c2=picker("transparent","black","red","yellow","orange","green","blue","pink","violet"),
c3=picker("transparent","black","red","yellow","orange","green","blue","pink","violet")
)

3D Data with ggplot

I have data in the following form:
x <- seq(from = 0.01,to = 1, by = 0.01)
y <- seq(from = 0.01,to = 1, by = 0.01)
xAxis <- x/(1+x*y)
yAxis <- x/(1+x*y)
z <- (0.9-xAxis)^2 + (0.5-yAxis)^2
df <- expand.grid(x,y)
xAxis <- df$Var1/(1+df$Var1*df$Var2)
yAxis <- df$Var2/(1+df$Var1*df$Var2)
df$x <- xAxis
df$y <- yAxis
df$z <- z
I would like to plot te (x,y,z) data as a surface and contour plots, possibily interpolating data to obtain as smooth a figure as possible.
Searching I reached the akima package which does the interpolation:
im <- with(df,interp(x,y,z))
I am having trouble plotting the data with this output. Ideally I would like to use ggplot2 since I want to add stuff to the original plot.
Thanks!
I'm a bit puzzled as to what you are looking for, but how about something like this?
im <- with(df, akima::interp(x, y, z, nx = 1000, ny = 1000))
df2 <- data.frame(expand.grid(x = im$x, y = im$y), z = c(im$z))
ggplot(df2, aes(x, y, fill = z)) +
geom_raster() +
viridis::scale_fill_viridis()
For contour plots, I use the "rgl" package. This allows real-time manipulation of the plot in order to have the best view.
library("rgl")
x <- seq(from = 0.01,to = 1, by = 0.01)
y <- seq(from = 0.01,to = 1, by = 0.01)
#z <- (0.9-xAxis)^2 + (0.5-yAxis)^2
df <- expand.grid(x,y)
xAxis <- df$Var1/(1+df$Var1*df$Var2)
yAxis <- df$Var2/(1+df$Var1*df$Var2)
df$z <- (0.9-xAxis)^2 + (0.5-yAxis)^2
surface3d(x=x, y=y, z=df$z, col="blue", back="lines")
title3d(xlab="x", zlab="z", ylab="y")
axes3d(tick="FALSE")
The rgl package is comparable to the ggplot2 package to customize the final plot. The 0.01 grid spacing is more than close enough for this type of smooth surface.

Resources