rgl package - cube within a cube - r

I'm trying to create a rectangular prism within a cube. I need the cube to have dimensions of 1x1x1 units, with an origin at 0,0,0. The rectangle within the cube would ideally start at the origin and then pull from a vector variable to get its XYZ dimensions. The rectangular prism can only have positive values that range from 0 to 1, which is why I only want to show positive values instead of what seems to be the default for cube3d of showing -1 to 1 in all dimensions around the origin.
Can someone point me in the right direction as to how to make this work?
Data example:
Augusta = c(0.4, 0.2, 0.8)
The code I currently have (pulled from stackoverflow) -
c3d <- cube3d(color="red", alpha=0.5)
c3d
shade3d(c3d)
axes3d()
rgl.viewpoint(theta = 45, phi = 25, fov = 60, zoom = 1)
Can I adapt this function to suit my needs? If so, what would the method look like? If this isn't the right function, what would you suggest?
Another potential method I found, but which would require a different input and would therefore not be preferred, is described here

I'm not sure if I can understand your problem, but perhaps scale3d() and translate3d() would give what you want (see: ?scale3d).
library(rgl)
c3d <- cube3d(color="red", alpha=0.5)
c3d2 <- c3d %>%
translate3d(1, 1, 1) %>%
scale3d(0.5, 0.5, 0.5)
c3d3 <- cube3d(color = "blue") %>%
translate3d(1, 1, 1) %>%
scale3d(0.5, 0.5, 0.5) %>%
scale3d(0.4, 0.2, 0.8)
shade3d(c3d2)
shade3d(c3d3)
axes3d()
# title3d(xlab = "x", ylab = "y", zlab = "z")

#Data example
Nominal_City_Name = c(0.7,0.2,0.5)
X = Nominal_City_Name[1]
Y = Nominal_City_Name[2]
Z = Nominal_City_Name[3]
#Bring in RGL library
library(rgl)
#Contributor cuttlefish44's code
c3d <- cube3d(color="grey", alpha=0.1)
c3d2 <- c3d %>%
translate3d(1, 1, 1) %>%
scale3d(0.5, 0.5, 0.5)
c3d3 <- cube3d(color = "blue", alpha = (0.5)) %>%
translate3d(1, 1, 1) %>%
scale3d(0.5, 0.5, 0.5) %>%
scale3d(X, Z, Y)
shade3d(c3d2)
shade3d(c3d3)
axes3d()
# Add points at vertices
points3d(t(c3d3$vb), size = 5)
# Add lines to edges of box
for (i in 1:6) lines3d(t(c3d3$vb)[c3d3$ib[,i],])
#------------Add labels/title to 3d window-------
# This version of title (commented out) doesn't work as well as the
# bgplot3d() version now included in output section below.
# Use this title3d() version if you want the title to be dynamic to
# the graphic.
#Title_XYZ = paste0(stakeholder," ","X, Y, Z")
#title3d(main =Title_XYZ,cex = 2, line = 2)
mtext3d("X Var",edge="x-+",line=2,las=2,cex=2,srt = 50,col =
"darkorange3")
mtext3d("Y Var",edge="z+-",line=2.5,las=2,cex=2, col =
"chartreuse4", srt = 90)
mtext3d("Z Var",edge="y-+",line=3,las=2,cex=2, col =
"darkblue")
#
#-------Create output file-------
#This section first sets the window view parameters and window size
# to what I want it to be. Then it exports to a location you choose.
# After dynamically moving it to look the way you want in 3d view -
# Use par3d() to get view attributes (i.e., windowRect (window size)
# info), among other measurements. Theta, phi, fov, and zoom give
# angles, field of vision, and zoom.
rgl.viewpoint(theta = 45, phi = 4, fov = 60, zoom = 1)
window_size = c(164,32,1259,1050)
par3d(windowRect = window_size)
#Adding title using a background plot. This must be done AFTER
#resizing the window, because it doesn't scale gracefully.
Title_XYZ = "This is your title"
bgplot3d(
plot.new() +
title(main = Title_XYZ, line = -10,cex.main=3))
#a = folder, b = stakeholder name, c = file extension, d = concat of
#all 3 for export
# a = "C:\\Users\\MyUserName\\Documents\\R\\export"
# b = Title_XYZ
# c=".jpg"
# d = paste0(a,b,c)
# rgl.snapshot(d)

Related

Drawing a series of circles in R

I made this image in powerpoint to illustrate what I am trying to do:
I am trying to make a series of circles (each of which are the same size) that "move" along the x-axis in consistent intervals; for instance, the center of each consecutive circle would be 2 points away from the previous circle.
I have tried several things, including the DrawCircle function from the DescTools package, but cant produce this. For example, here I am trying to draw 20 circles, where the center of each circle is 2 points away from the previous, and each circle has a radius of 2 (which doesnt work)
library(DescTools)
plotdat <- data.frame(xcords = seq(1,50, by = 2.5), ycords = rep(4,20))
Canvas()
DrawCircle(x=plotdat$xcords, y=plotdat$ycords, radius = 2)
How can this be done in R?
This is basically #Peter's answer but with modifications. Your approach was fine but there is no radius= argument in DrawCircle. See the manual page ?DrawCircle for the arguments:
dev.new(width=12, height=4)
Canvas(xlim = c(0,50), ylim=c(2, 6), asp=1, xpd=TRUE)
DrawCircle(x=plotdat$xcords, y=plotdat$ycords, r.out = 2)
But your example has axes:
plot(NA, xlim = c(0,50), ylim=c(2, 6), xlab="", ylab="", yaxt="n", asp=1, xpd=TRUE)
DrawCircle(x=plotdat$xcords, y=plotdat$ycords, r.out = 2)
My solution requires the creation of some auxiliary functions
library(tidyverse)
##First function: create circle with a predefined radius, and a x-shift and y-shift
create_circle <- function(radius,x_shift, y_shift){
p <- tibble(
x = radius*cos(seq(0,2*pi, length.out = 1000)) + x_shift ,
y = radius*sin(seq(0,2*pi, length.out = 1000))+ y_shift
)
return(p)
}
##Use lapply to create circles with multiple x shifts:
##Group is only necessary for plotting
l <- lapply(seq(0,40, by = 2), function(i){
create_circle(2,i,0) %>%
mutate(group = i)
})
##Bind rows and plot
bind_rows(l) %>%
ggplot(aes(x = x, y = y, group =group)) +
geom_path()
Does this do the trick?
library(DescTools)
plotdat <- data.frame(xcords = seq(1, 5, length.out = 20), ycords = rep(4,20))
Canvas(xlim = c(0, 5), xpd=TRUE)
DrawCircle(x=plotdat$xcords, y=plotdat$ycords, r.out = 2)
I've assumed when you say circle centres are 2 points apart you mean 0.2 units apart.
You may have to experiment with the values to get what you need.

Connect all points using lines and write text above it using R

I'm trying to connect every point in my array with all other points in this array using line segment and write some text slightly above this lines. So, I want to achieve next:
I already tried to use segments() and lines() functions, but I don't know how can I do exactly what I described.
And as I said, now I have only array of coordinates and array of strings which I want to write.
How can I achieve this(It will be good if I will need to use only standard R libraries)?
UPD:
dataset.csv:
,A,B,C
A,0,1,2
B,1,0,3
C,2,3,0
script.r:
myDataset <- read.csv("dataset.csv")
row.names(myDataset) <- myDataset[, 1]
myDataset <- myDataset[, -1]
d <- dist(myDataset)
fit <- cmdscale(d,eig=TRUE, k=2)
x <- fit$points[,1]
y <- fit$points[,2]
Here's an example that uses combn to generate combinations of two points and then draw lines between them and to compute distances and write them in the middle too.
#DATA
set.seed(42)
df = data.frame(x = rnorm(4), y = rnorm(4))
#DRAW POINTS
plot(df)
#DRAW LINES
combn(1:NROW(df), 2, function(x)
lines(df[x,]), simplify = FALSE)
#WRITE TEXT
combn(1:NROW(df), 2, function(x)
text(x = mean(df[x,1]), #calculate center point x-value in the line
y = mean(df[x,2]), #calculate center point y-value in the line
labels = round(dist(df[x,]), 2), #calculate distance to write
srt = 180 * atan(diff(df[x, 2])/diff(df[x,1]))/pi, #calculate rotation angle of text
pos = 3, #place text slightly above given x and y
font = 2), #bold text
simplify = FALSE)
UPDATE
myDataset <- read.csv(strip.white = TRUE, stringsAsFactors = FALSE, header = TRUE, text = ",A,B,C
A,0,1,2
B,1,0,3
C,2,3,0")
row.names(myDataset) <- myDataset[, 1]
myDataset <- myDataset[, -1]
d <- dist(myDataset)
fit <- cmdscale(d,eig=TRUE, k=2)
x <- fit$points[,1]
y <- fit$points[,2]
df = data.frame(x, y)
#DRAW POINTS
plot(df, asp = 1)
text(x = df[,1], y = df[,2], labels = rownames(df), pos = 1)
#Create a list of combination of indices
temp = combn(1:NROW(df), 2, simplify = FALSE)
#DRAW LINES
sapply(temp, function(i) lines(df[i,]))
#WRITE TEXT
sapply(temp, function(x)
text(x = mean(df[x,1]), #calculate center point x-value in the line
y = mean(df[x,2]), #calculate center point y-value in the line
labels = myDataset[cbind(which(row.names(myDataset) == row.names(df)[x[1]]),
which(colnames(myDataset) == row.names(df)[x[2]]))],
srt = 180 * atan(diff(df[x, 2])/diff(df[x,1]))/pi, #calculate rotation angle of text
pos = 3, #place text slightly above given x and y
font = 2), #bold text
simplify = FALSE)
Trying to achieve this with graphics primitives (such as lines) is bound to be a pain.
Use a dedicated library for graph plotting instead, e.g. ggraph. The “Edges” vignette has an example with edge labels:
ggraph(simple, layout = 'graphopt') +
geom_edge_link(aes(label = type),
angle_calc = 'along',
label_dodge = unit(2.5, 'mm'),
arrow = arrow(length = unit(4, 'mm')),
end_cap = circle(3, 'mm')) +
geom_node_point(size = 5)
The one drawback: ggraph doesn’t allow you to explicitly set the node positions; however, you can manipulate them manually.

Complete missing lines using rgl grid3d

Does anyone know of a way to 1) complete the missing gridlines in the grid3d call for y, and 2) draw horizontal gridlines to close the top of the grids constructed by the grid3d calls for x and y? I've played around with various combinations of pretty calls within grid3d to no avail and am wondering if this is an rgl quirk or a misspecification on my part. Additionally, I'd like to extend the vertical axis numbering to wherever the closed grids end up.
library(rgl)
cpts <- seq(0, 2, length = 40)
spts <- seq(0, 1, length = 20)
grid <- expand.grid(s=spts, c=cpts)
UFn <- function(s,c){c^(0.5) - exp(s) + 1}
U <- UFn(grid$s, grid$c)
open3d()
rgl.surface(x = spts, y = matrix(U,nrow = 40, ncol = 20), z = cpts,
coords = c(1,3,2), specular = "black")
axes3d("x", at = pretty(spts, n = 2), color = "black")
axes3d("y", at = pretty(cpts, n = 5), color = "black")
axes3d("z--", color = "black")
grid3d("x")
grid3d("y", at = pretty(spts, n = 2))
title3d(xlab ='s', ylab = 'c', zlab = 'U', color = "black")
rgl.snapshot("3d.png")
I would say it is a bug. You don't get any z-lines when using grid3d("y",n=2) even though it should be the same. You can work around it by using the list specification of at, setting the x element of the list, eg:
grid3d("y", at = list(x=pretty(spts, n = 2)))

How to plot bivariate normal contour in R [duplicate]

I have been playing around with the MASS package and can plot the two bivariate normal simply using image and par(new=TRUE) for example:
# lets first simulate a bivariate normal sample
library(MASS)
bivn <- mvrnorm(1000, mu = c(0, 0), Sigma = matrix(c(1, .5, .5, 1), 2))
bivn2 <- mvrnorm(1000, mu = c(0, 0), Sigma = matrix(c(1.5, 1.5, 1.5, 1.5), 2))
# now we do a kernel density estimate
bivn.kde <- kde2d(bivn[,1], bivn[,2], n = 50)
bivn.kde2 <- kde2d(bivn2[,1], bivn[,2], n = 50)
# fancy perspective
persp(bivn.kde, phi = 45, theta = 30, shade = .1, border = NA)
par(new=TRUE)
persp(bivn.kde2, phi = 45, theta = 30, shade = .1, border = NA)
Which doesn't look very good, I guess I have to just play around with the axis and stuff.
But if I try a similar approach with the contour the plots do not overlap. They are simply replaced:
# fancy contour with image
image(bivn.kde); contour(bivn.kde, add = T)
par(new=TRUE)
image(bivn.kde2); contour(bivn.kde, add = T)
Is this the best approach to what I want or am I just making it hard on myself? Any suggestions are welcome. Thank you!
Perhaps you can use rgl library. It allows you to create interactive 3d plots.
require(rgl)
col1 <- rainbow(length(bivn.kde$z))[rank(bivn.kde$z)]
col2 <- heat.colors(length(bivn.kde2$z))[rank(bivn.kde2$z)]
persp3d(x=bivn.kde, col = col1)
with(bivn.kde2, surface3d(x,y,z, color = col2))
If you want to plot difference between two surfaces then you can do something like below.
res <- list(x = bivn.kde$x, y = bivn.kde$y, z = bivn.kde$z - bivn.kde2$z)
col3 <- heat.colors(length(res$z))[rank(res$z)]
persp3d(res, col = col3)

R - Plotting two bivariate normals in 3d and their contours respectively

I have been playing around with the MASS package and can plot the two bivariate normal simply using image and par(new=TRUE) for example:
# lets first simulate a bivariate normal sample
library(MASS)
bivn <- mvrnorm(1000, mu = c(0, 0), Sigma = matrix(c(1, .5, .5, 1), 2))
bivn2 <- mvrnorm(1000, mu = c(0, 0), Sigma = matrix(c(1.5, 1.5, 1.5, 1.5), 2))
# now we do a kernel density estimate
bivn.kde <- kde2d(bivn[,1], bivn[,2], n = 50)
bivn.kde2 <- kde2d(bivn2[,1], bivn[,2], n = 50)
# fancy perspective
persp(bivn.kde, phi = 45, theta = 30, shade = .1, border = NA)
par(new=TRUE)
persp(bivn.kde2, phi = 45, theta = 30, shade = .1, border = NA)
Which doesn't look very good, I guess I have to just play around with the axis and stuff.
But if I try a similar approach with the contour the plots do not overlap. They are simply replaced:
# fancy contour with image
image(bivn.kde); contour(bivn.kde, add = T)
par(new=TRUE)
image(bivn.kde2); contour(bivn.kde, add = T)
Is this the best approach to what I want or am I just making it hard on myself? Any suggestions are welcome. Thank you!
Perhaps you can use rgl library. It allows you to create interactive 3d plots.
require(rgl)
col1 <- rainbow(length(bivn.kde$z))[rank(bivn.kde$z)]
col2 <- heat.colors(length(bivn.kde2$z))[rank(bivn.kde2$z)]
persp3d(x=bivn.kde, col = col1)
with(bivn.kde2, surface3d(x,y,z, color = col2))
If you want to plot difference between two surfaces then you can do something like below.
res <- list(x = bivn.kde$x, y = bivn.kde$y, z = bivn.kde$z - bivn.kde2$z)
col3 <- heat.colors(length(res$z))[rank(res$z)]
persp3d(res, col = col3)

Resources