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))
Related
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 have a function , foo(x,y), that creates a 3d surface from x,y coordinates. I need to find all values of (x,y) where foo=0. Currently, I am calculating foo at every point on an (x,y) search grid, but this is computationally expensive. Is there a way to give R foo, and have it return all values of (x,y) where foo=0?
With contourLines:
foo <- function(x,y) x^2 + y^2 - 1
x <- y <- seq(-2, 2, len=200)
z <- outer(x, y, foo)
cr <- contourLines(x, y, z, levels=0)
> x <- cr[[1]]$x
> y <- cr[[1]]$y
> foo(x[10], y[10])
[1] -4.438003e-05
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)
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
I would like to plot:
production.ts(31, .002, 10,12,125313.93,211,95,x,"2014-02-01","2014-05-14",z,y) as function of x,y,z
As something like this plot from Mathematica, (if possible in R):
http://i.stack.imgur.com/3PRaf.png
I have a function:
library("lubridate"); library("rgl")
production.ts <- function(a, b, z, c, d, e,
f, g, h, j, r, k) {
elapsed <- (4-z)*10 + (4-c)
un.days <- 100 - elapsed
gone.days <- day(as.Date(h))
rem.days <- day(as.Date(j))
r.days <- as.numeric(as.Date(j) - as.Date(h))
m.r <- f/100*d
inputs <- d * a * (gone.days - 1)/365 + r
prin <- m.r + inputs
costs <- (r.days/365 * r + 1) * prin
added.p <- a/100*d + r
due <- d * 1-un.days
tomr.f <- 1- due + k^2
acct.paid <- (d - due)*tomr.f
net <- added.p + due + acct.paid
pv.net <- net/(1+r*(e-30-day(as.Date(j)))/365)
end <- d - due - acct.paid
more.add.p <- end*a*(rem.days-1)/365
rem <- (f-g)/100 * end
total.fv <- pv.net + rem + more.add.p
out <- costs - total.fv
out
}
x<-seq(-10,10,by=.1)
y<-seq(0,1000,by=.1)
z<-seq(0,90,by=.1)
I have tried:
func.3d<-Vectorize(production.ts(31, .002, 10,12,125313.93,211,95,x,"2014-02-01","2014-05-14",z,y))
c <- func.3d; c <- cut(c,breaks=64); cols <- rainbow(64)[as.numeric(c)]
open3d()
plot3d(x, y, z, col=cols,type="s",size=1)
But this plots lines and the colors don't line up with the values the function should output.
Does anyone know how I could do this? Thanks, I really appreciate your time!
Like this?
x<-seq(-10,10,length=100)
y<-seq(0,1000,length=100)
z<-seq(0,90,length=100)
df <- expand.grid(x=x,y=y,z=z)
f <- function(x,y,z) {production.ts(31, .002, 10,12,125313.93,211,95,x,"2014-02-01","2014-05-14",z,y)}
df$c <- f(df$x,df$y,df$z)
c <- cut(df$c,breaks=64)
cols <- rainbow(64)[as.numeric(c)]
open3d()
plot3d(df$x, df$y, df$z, col=cols,type="p",size=1)
Your code was not plotting lines. When you pass x, y, and z like that to plot3d(...) it cycles through all the elements together, so x[1],y[1],z[1] is a point, x[2],y[2],z[2] is another point, and so on. Since the vectors are different lengths, the shorter ones are recycled to fill out to the length of the longest. The visual effect of this is that the points lie on a line.
You want yo plot every combination of x, y, and z, and give each point a color based on that combination. The code above does that. The plot does not quite look like yours, but I can't tell if that is because of the way you have defined your function.
Also, the way you defined x, y, and z there would be 201 X 10001 X 901 = 1,811,191,101 points, which is too many to handle. The code above plots 1,000,000 points.
Finally, plotting spheres (type="s") is very expensive and unnecessary in this case.