I use the ellipsoidhull method from cluster package to obtain the minimum volume enclosing ellipsoid (mvee) from a set of points. This method returns an object of class ellipsoid. I need to plot the generated ellipsoid. I tried to use the wire3d method from rgl package to plot ellipsoids but this method gets objects of class mesh3d as input parameter. How can I convert an ellipsoid object to a mesh3d object?
If you don't actually care about a mesh, and are just looking to plot a transparent ellipsoid you can use this:
library(rgl)
library(cluster)
open3d()
ellipsoid3d <- function(cen, a = 1,b = 1,c = 1,n = 65, ...){
f <- function(s,t){
cbind( a * cos(t)*cos(s) + cen[1],
b * sin(s) + cen[2],
c * sin(t)*cos(s) + cen[3])
}
persp3d(f, slim = c(-pi/2,pi/2), tlim = c(0, 2*pi), n = n, add = T, ...)
}
set.seed(123)
n <- 6
for (i in 1:n){
cen <- 3*runif(3)
a <- runif(1)
b <- runif(1)
c <- runif(1)
clr <- c("red","blue","green")[i %% 3 + 1 ]
elpf <- ellipsoid3d(cen,a=a,b=b,c=c,col=clr,alpha=0.5)
}
Yielding:
I modified the interesting answer from cuttlefish44 to get this - see this link: enter link description here
There is also a qmesh3d answer from dww there that you could modify in a similar manner to get a mesh3d if that is what you really want, but I thought this more elegant.
library(cluster)
xyz <- cbind(rnorm(10), rnorm(10), rnorm(10))
e <- ellipsoidhull(xyz)
A <- e$cov
center <- e$loc
r <- sqrt(e$d2)
library(Rvcg)
sphr <- vcgSphere()
library(rgl)
ell <- translate3d(
scale3d(
transform3d(sphr, chol(A)),
r, r, r),
center[1], center[2], center[3])
shade3d(ell, color="red", alpha=0.3)
points3d(xyz)
Related
I normally do all my plotting using ggplot but now I am working with standardized survival curves using a package called stdCoxph. My question is: Does anyone know how to change the color and thickness of these lines. I have tried to use col and lwd, but it does not change anything. See reproducible example below:
#Load packages:
if(!require(stdReg)){install.packages("stdReg", dependencies=TRUE)}
library(stdReg)
library(survival)
n <- 1000
Z <- rnorm(n)
X <- rnorm(n, mean=Z)
Tm <- rexp(n, rate=exp(X+Z+X*Z)) #survival time
C <- rexp(n, rate=exp(X+Z+X*Z)) #censoring time
U <- pmin(Tm, C) #time at risk
D <- as.numeric(Tm < C) #event indicator
dd <- data.frame(Z, X, U, D)
fit <- coxph(formula=Surv(U, D)~ X*Z, data=dd, method="breslow")
# in R formulas ~X*C will be interpreted as ~X+Z+X:Z
fit.std <- stdCoxph(fit=fit, data=dd, X="X", x=seq(-1,1,0.5), t=1:5)
print(summary(fit.std, t=3))
plot(fit.std)
col is hard coded but the other plot parameters can be modified with par :
opar <- par(lwd = 3)
plot(std.fit)
par(opar) # reset back
To change the colors redefine plot.stdCoxph adding a colors argument. This makes a copy of plot.stdCoxph which calls a local copy of lines and legend that use the specified colors.
plot.stdCoxph <- function(x, ..., colors = seq_along(x)) {
lines <- function(x, ..., col) graphics::lines(x, ..., col = colors[col])
legend <- function(x, ..., col) graphics::legend(x, ..., col = colors[col])
plot.stdCoxph <- stdReg:::plot.stdCoxph
environment(plot.stdCoxph) <- environment()
plot.stdCoxph(x, ...)
}
plot(fit.std, colors = rainbow(5)) # test
You could consider contacting the maintainer of the package and ask if they could provide similar functionality without this workaround.
I would like to plot a sphere in R with the gridlines on the surface corresponding to the equal area gridding of the sphere using the arcos transformation.
I have been experimenting with the R packakge rgl and got some help from :
Plot points on a sphere in R
Which plots the gridlines with equal lat long spacing.
I have the below function which returns a data frame of points that are the cross over points of the grid lines I want, but not sure how to proceed.
plot_sphere <- function(theta_num,phi_num){
theta <- seq(0,2*pi,(2*pi)/(theta_num))
phi <- seq(0,pi,pi/(phi_num))
tmp <- seq(0,2*phi_num,2)/phi_num
phi <- acos(1-tmp)
tmp <- cbind(rep(seq(1,theta_num),each = phi_num),rep(seq(1,phi_num),times = theta_num))
results <- as.data.frame(cbind(theta[tmp[,1]],phi[tmp[,2]]))
names(results) <- c("theta","phi")
results$x <- cos(results$theta)*sin(results$phi)
results$y <- sin(results$theta)*sin(results$phi)
results$z <- cos(results$phi)
return(results)
}
sphere <- plot_sphere(10,10)
Can anyone help, in general I am finding the rgl functions tricky to work with.
If you use lines3d or plot3d(..., type="l"), you'll get a plot joining the points in your dataframe. To get breaks (you don't want one long line), add rows containing NA values.
The code in your plot_sphere function seems really messed up (you compute phi twice, you don't generate vectors of the requested length, etc.), but this function based on it works:
function(theta_num,phi_num){
theta0 <- seq(0,2*pi, len = theta_num)
tmp <- seq(0, 2, len = phi_num)
phi0 <- acos(1-tmp)
i <- seq(1, (phi_num + 1)*theta_num) - 1
theta <- theta0[i %/% (phi_num + 1) + 1]
phi <- phi0[i %% (phi_num + 1) + 1]
i <- seq(1, phi_num*(theta_num + 1)) - 1
theta <- c(theta, theta0[i %% (theta_num + 1) + 1])
phi <- c(phi, phi0[i %/% (theta_num + 1) + 1])
results <- data.frame( x = cos(theta)*sin(phi),
y = sin(theta)*sin(phi),
z = cos(phi))
lines3d(results)
}
I'd like to know if there is a way to produce plots in R function similar to Mathematica's ContourPlot3D function? Basically, it allows you to plot a 3D surface at values of f, where f is an implicit function in three variables. The example from Mathematica: f(x,y,z) = x^3 + y^2 + z^2.
x <- y <- z <- seq(-2, 2, by=0.2)
grid <- expand.grid(x=x,y=y,z=z)
grid$f <- x^3 + y^2 + z^2
You can try the plot3D package.
The vignette has similar examples to the Mathematica link you provided.
Install the package, scan the vignette for the relevant function you want and try out that functions examples. For instance, if you want to look at the contour3D function and the surf3D function:
install.packages("plot3D")
require("plot3D")
example(contour3D)
example(surf3D)
You may want slice3D() or isosurf3D().
You can also try the misc3d package.
require(misc3d)
x <- y <- z <- seq(-2, 2, by=0.2)
x <- seq(-2,2,len=50)
g <- expand.grid(x = x, y = x, z = x)
v <- array(g$x^3 + g$y^2 + g$z^2, rep(length(x),3))
con <- computeContour3d(v, max(v), level=.2)
drawScene(makeTriangles(con))
This is my first post to the R-community, so pardon me if it is silly. I would like to use the functions geom_density2d and stat_density2d in ggplot2 to plot kernel density estimates, but the problem is that they can't handle weighted data. From what I understand, these two functions call the function kde2d from package MASS to make the kernel density estimate. And the kde2d doesn't take data weights as a parameter.
Now, I have found this altered version of kde2d http://www.inside-r.org/node/226757, which takes weights as a parameter and is based on the source code of kde2d. The code of this function:
kde2d.weighted <- function (x, y, w, h, n = 25, lims = c(range(x), range(y))) {
nx <- length(x)
if (length(y) != nx)
stop("data vectors must be the same length")
if (length(w) != nx & length(w) != 1)
stop("weight vectors must be 1 or length of data")
gx <- seq(lims[1], lims[2], length = n) # gridpoints x
gy <- seq(lims[3], lims[4], length = n) # gridpoints y
if (missing(h))
h <- c(bandwidth.nrd(x), bandwidth.nrd(y));
if (missing(w))
w <- numeric(nx)+1;
h <- h/4
ax <- outer(gx, x, "-")/h[1] # distance of each point to each grid point in x-direction
ay <- outer(gy, y, "-")/h[2] # distance of each point to each grid point in y-direction
z <- (matrix(rep(w,n), nrow=n, ncol=nx, byrow=TRUE)*matrix(dnorm(ax), n, nx)) %*% t(matrix(dnorm(ay), n, nx))/(sum(w) * h[1] * h[2]) # z is the density
return(list(x = gx, y = gy, z = z))
}
I would like to make the functions geom_density2d and stat_density2d call kd2d.weighted instead of kde2d, and by that making them accept weighted data.
I have never changed any functions in existing R packages so my question is what is the easiest way doing this?
You can actually pass your own density data to geom_contour which would probably be the easiest. Let's start with a sample dataset by adding weights to the geyser data.
library("MASS")
data(geyser, "MASS")
geyserw <- transform(geyser,
weight = sample(1:5, nrow(geyser), replace=T)
)
Now we use your weighted function to calculate the density and turn it into a data.frame
dens <- kde2d.weighted(geyserw$duration, geyserw$waiting, geyserw$weight)
dfdens <- data.frame(expand.grid(x=dens$x, y=dens$y), z=as.vector(dens$z))
Now we plot the data
ggplot(geyserw, aes(x = duration, y = waiting)) +
geom_point() + xlim(0.5, 6) + ylim(40, 110) +
geom_contour(aes(x=x, y=y, z=z), data= dfdens)
And that should do it
It seems that a statistical problem that I am working on requires doing something known in computational geometry as "offline orthogonal range counting":
Suppose I have a set of n points (for the moment, in the plane). For every pair of points i and j, I would like to count the number of remaining points in the set that are in the rectangle whose diagonal is the segment with endpoints i and j. The overall output then is a vector of n(n-1) values each in [0, 1, 2, ... , n-2].
I've seen that a rich literature on the problem (or at least a very similar problem) exists, but I cannot find an implementation. I would prefer an R (a statistical computing language) package, but I guess that's asking too much. An open source C/C++ implementation will also work.
Thanks.
I hope I understand well your proble. Here an implementation in R using package geometry. I use
mesh.drectangle function which compute a signed distance from points p to boundary of rectangle.
I create a combination for all points using combn
for each point p of combination , I compute the distance from the rectangle rect_p to the others points
if distance < 0 I choose the points.
For example
library(geometry)
## I generate some data
set.seed(1234)
p.x <- sample(1:100,size=30,replace=T)
p.y <- sample(1:100,size=30,replace=T)
points <- cbind(p.x,p.y)
## the algortithm
ll <- combn(1:nrow(points),2,function(x){
x1<- p.x[x[1]]; y1 <- p.y[x[1]]
x2<- p.x[x[2]]; y2 <- p.y[x[2]]
p <- points[-x,]
d <- mesh.drectangle(p,x1,y1,x2,y2)
res <- NA
if(length(which(d <0))){
points.in = as.data.frame(p,ncol=2)[ d < 0 , ]
res <- list(n = nrow(points.in),
rect = list(x1=x1,x2=x2,y1=y1,y2=y2),
points.in = points.in)
}
res
},simplify=F)
ll <- ll[!is.na(ll)]
## the result
nn <- do.call(rbind,lapply(ll,'[[','n'))
To visualize the results, I plots rectangles with 5 points for example.
library(grid)
grid.newpage()
vp <- plotViewport(xscale = extendrange(p.x),
yscale = extendrange(p.y))
pushViewport(vp)
grid.xaxis()
grid.yaxis()
grid.points(x=points[,'p.x'],y=points[,'p.y'],pch='*')
cols <- rainbow(length(ll))
ll <- ll[nn == 5] ## here I plot only the rectangle with 5 points
lapply(seq_along(ll),function(i){
x <- ll[[i]]
col <- sample(cols,1)
x1<- x$rect$x1; x2<- x$rect$x2
y1<- x$rect$y1; y2<- x$rect$y2
grid.rect(x=(x1+x2)*.5,y=(y1+y2)*.5,
width= x2-x1,height = y2-y1,
default.units ='native',
gp=gpar(fill=col,col='red',alpha=0.2)
)
grid.points(x=x$points.in$p.x,y=x$points.in$p.y,pch=19,
gp=gpar(col=rep(col,x$n)))
}
)
upViewport()