Related
I am working with the R programming language.
In a previous question that I asked (Understanding 3D traces in Plotly and R: Evaluating and Plotting Functions Over a Grid), I learned how to plot mathematical functions by first evaluating the mathematical function at different points, then by plotting these points on a 3D grid, and finally "interpolating" a 3D surface over these points:
# set seed for reproducibility
#load libraries
set.seed(123)
library(dplyr)
library(plotly)
#create more data
n <- 50
my_grid <- expand.grid(i1 = 1:n, i2 = 1:n)
my_grid$final_value = with(my_grid, sin(i1) + cos(i2) )
#make plot
plot_ly(data = my_grid, x=~i1, y=~i2, z=~final_value, type='mesh3d', intensity = ~final_value, colors = colorRamp(c("blue", "grey", "red")))
I am trying to use this same approach to plot the following function (https://en.wikipedia.org/w/index.php?title=Test_functions_for_optimization&oldid=1030693803, https://en.wikipedia.org/w/index.php?title=Test_functions_for_optimization&oldid=1030693803#/media/File:ConstrTestFunc03.png) :
I first defined the function:
my_function <- function(x,y) {
final_value = (1 - x)^2 + 100*((y - x^2)^2)
}
Then, I defined the "grid":
input_1 <- seq(-1.5, 1.5,0.1)
input_2 <- seq(-1.5, 1.5,0.1)
my_grid <- data.frame(input_1, input_2)
my_grid$final_value = (1 - input_1)^2 + 100*((input_2 - input_1^2)^2)
Then, I tried to plot this function:
x <- my_grid$input_1
y <- my_grid$input_2
z <- matrix(my_grid$final_value, nrow = length(x), ncol = length(y)) # proper matrix & dimensions
plot_ly(x = x, y = y, z = z) %>% add_surface()
My Problem: The final result does not look similar to the result from the Wikipedia page:
Can someone please show me what I am doing wrong? Is there an easier way to do this?
Thanks!
Your problem is that you are not actually creating a grid, you are creating a single vector of equal x, y points and running your formula on that, so your matrix is wrong (every column will be the same due to it being repeated). The easiest fix is to run outer on your function to evaluate it at every pair of input 1 and input 2:
z <- outer(input_1, input_2, my_function)
plot_ly(x = input_1, y = input_2, z = z) %>% add_surface()
My data:
a <- sample(1:5, 100, replace = TRUE)
b <- sample(1:5, 100, replace = TRUE)
c <- sample(1:10, 100, replace = TRUE)
d <- sample(1:40, 100, replace = TRUE)
df <- data.frame(a, b, c, d)
Using ggplot2, I have created scatterplot over x = a and y = b, weighted in two dimension (by colour = c and size = d). Note that x and y are intentionally 1:5.
Obviously, the points of different sizes and colors therefore overlap, so I tried jitter to avoid overlapping:
ggplot(df, aes(a, b, colour = c, size = d)) +
geom_point(position = position_jitter())
Now I would like the dots clustering closer together, so I tried several
combinations of height and width for the jitter function, such as
ggplot(df, aes(a, b, colour = c, size = d)) +
geom_point(position = position_jitter(width = 0.2, height = 0.2))
Jitter makes the dots still overlap and also distributes them to randomly on the given area.
Is there a way to have the dots not overlapping at all, yet clustered as close together as possible, maybe even touching and also not "side by side" or stacked? (In a way, creating kind of bubbles with smaller dots)?
Thanks!
According to #Tjebo's suggestions I have arranged dots in "heaps".
set.seed(1234)
n <- 100
a <- sample(1:5,n,rep=TRUE)
b <- sample(1:5,n,rep=TRUE)
c <- sample(1:10,n,rep=TRUE)
d <- sample(1:40,n,rep=TRUE)
df0 <- data.frame(a,b,c,d)
# These parameters need carefully tuning
minr <- 0.05
maxr <- 0.2
# Order circles by dimension
ord <- FALSE
df1 <- df0
df1$d <- minr+(maxr-minr)*(df1$d-min(df1$d))/(max(df1$d)-min(df1$d))
avals <- unique(df1$a)
bvals <- unique(df1$b)
for (k1 in seq_along(avals)) {
for (k2 in seq_along(bvals)) {
print(paste(k1,k2))
subk <- (df1$a==avals[k1] & df1$b==bvals[k2])
if (sum(subk)>1) {
subdfk <- df1[subk,]
if (ord) {
idx <- order(subdfk$d)
subdfk <- subdfk[idx,]
}
subdfk.mod <- subdfk
posmx <- which.max(subdfk$d)
subdfk1 <- subdfk[posmx,]
subdfk2 <- subdfk[-posmx,]
angsk <- seq(0,2*pi,length.out=nrow(subdfk2)+1)
subdfk2$a <- subdfk2$a+cos(angsk[-length(angsk)])*(subdfk1$d+subdfk2$d)/2
subdfk2$b <- subdfk2$b+sin(angsk[-length(angsk)])*(subdfk1$d+subdfk2$d)/2
subdfk.mod[posmx,] <- subdfk1
subdfk.mod[-posmx,] <- subdfk2
df1[subk,] <- subdfk.mod
}
}
}
library(ggplot2)
library(ggforce)
ggplot(df1, aes()) +
geom_circle(aes(x0=a, y0=b, r=d/2, fill=c), alpha=0.7)+ coord_fixed()
An interesting visualization tool is the beeswarm plot.
In R the beeswarm and the ggbeeswarm packages implement this kind of plot.
Here is an example with ggbeeswarm:
set.seed(1234)
a <- sample(1:5,100,rep=TRUE)
b <- sample(1:5,100,rep=TRUE)
c <- sample(1:10,100,rep=TRUE)
d <- sample(1:40,100,rep=TRUE)
df <- data.frame(a,b,c,d)
library(ggbeeswarm)
ggplot(aes(x=a, y=b, col=c, size=d), data = df)+
geom_beeswarm(priority='random',cex=3.5, groupOnX=T)+coord_flip()
I hope this can help you.
Here is another possibile solution to the jittering problem of #Tjebo.
The parameter dst needs some tuning.
set.seed(1234)
a <- sample(1:5,100,rep=TRUE)
b <- sample(1:5,100,rep=TRUE)
c <- sample(1:10,100,rep=TRUE)
d <- sample(1:40,100,rep=TRUE)
df <- data.frame(a,b,c,d)
dst <- .2
df.mod <- df
avals <- unique(df$a)
bvals <- unique(df$b)
for (k1 in seq_along(avals)) {
for (k2 in seq_along(bvals)) {
subk <- (df$a==avals[k1] & df$b==bvals[k2])
if (sum(subk)>1) {
subdf <- df[subk,]
angsk <- seq(0,2*pi,length.out=nrow(subdf)+1)
ak <- subdf$a+cos(angsk[-1])*dst
bk <- subdf$b+sin(angsk[-1])*dst
df.mod[subk,c("a","b")] <- cbind(ak,bk)
}
}
}
library(ggplot2)
ggplot(df.mod, aes(a, b, colour = c, size = d)) + geom_point()
I'm having a problem with faceted heatmap rendering in ggplot2. The idea is that I have several elements (these are genes in the real life) and several experiments (F1 and F2 in the example below). Using the F1 experiment, I'm able to create class of elements/genes based on their mean expression (high, ..., moderate, ..., low). In the heatmap produced through the example below, I would like to order each elements in each class (01, 02, 03, 04) based on its mean expression value in F1. Unfortunately, the elements appear in alphabetic order. I would be very happy to get some hints...
Best
library(ggplot2)
library(reshape2)
set.seed(123)
# let's create a fake dataset
nb.experiment <- 4
n.row <- 200
n.col <- 5
d <- matrix(round(runif(n.row * n.col),2), nc=n.col)
colnames(d) <- sprintf("%02d", 1:5)
# These strings will be the row names of each heatmap
# in the subsequent facet plot
elements <- sample(replicate(n.row/2, rawToChar(as.raw(sample(65:90, 6, replace=T)))))
# let's create a data.frame d
d <- data.frame(d,
experiment = sort(rep(c("F1","F2"), n.row/2)),
elements= elements)
# For elements related to experiment F1
# we artificially produce a gradient of values that will
# create elements with increasing row means
d[d$experiment =="F1",1:5] <- round(sweep(d[d$experiment =="F1",1:5],
1,
seq(from=1, 10, length.out = 100),
"+"), 2)
# For elements related to experiment F2
# we artificially produce a gradient of values that will
# create elements with decreasing row means
d[d$experiment =="F2",1:5] <- round(sweep(d[d$experiment =="F2",1:5],
1,
seq(from=10, 1, length.out = 100),
"+"), 2)
#print(d[d$experiment =="F1",1:5])
# Now we split the dataset by experiments
d.split <- split(d, d$experiment)
# For all experiments, we order elements based on the mean expression signal in
# F1.
row.means.F1 <- rowMeans(d.split$F1[,1:5])
pos <- order(row.means.F1)
for(s in names(d.split)){
d.split[[s]] <- d.split[[s]][pos,]
}
# We create several classes of elements based on their
# mean expression signal in F1.
cuts <- cut(1:nrow(d.split$F1), nb.experiment)
levels(cuts) <- sprintf("%02d", 1:nb.experiment)
for(s in names(d.split)){
d.split[[s]] <- split(d.split[[s]], cuts)
}
# Data are melt (their is perhaps a better solution...)
# in order to use the ggplot function
dm <- melt(do.call('rbind',lapply(d.split, melt)), id.var=c( "experiment", "elements", "variable", "L1"))
dm <- dm[, -5]
colnames(dm) <- c("experiment","elements", "pos", "rowMeanClass", "exprs")
# Now we plot the data
p <- ggplot(dm, aes(x = pos, y = elements, fill = exprs))
p <- p + geom_raster()
p <- p + facet_wrap(~rowMeanClass +experiment , scales = "free", ncol = 2)
p <- p + theme_bw()
p <- p + theme(text = element_text(size=4))
p <- p + theme(text = element_text(family = "mono", face = "bold"))
ggsave("RPlot_test.jpeg", p)
Using your advises I was able to find a solution (which implies to clearly specify the order of levels for the 'elements' factor). Thank you #hrbrmstr (and all others).
NB: I only added few lines compare to the original code that are denoted below with 'Added: begin' and 'Added: end' flags.
library(ggplot2)
library(reshape2)
set.seed(123)
# let's create a fake dataset
nb.experiment <- 4
n.row <- 200
n.col <- 5
d <- matrix(round(runif(n.row * n.col),2), nc=n.col)
colnames(d) <- sprintf("%02d", 1:5)
# These strings will be the row names of each heatmap
# in the subsequent facet plot
elements <- sample(replicate(n.row/2, rawToChar(as.raw(sample(65:90, 6, replace=T)))))
# let's create a data.frame d
d <- data.frame(d,
experiment = sort(rep(c("F1","F2"), n.row/2)),
elements= elements)
# For elements related to experiment F1
# we artificially produce a gradient of values that will
# create elements with increasing row means
d[d$experiment =="F1",1:5] <- round(sweep(d[d$experiment =="F1",1:5],
1,
seq(from=1, 10, length.out = 100),
"+"), 2)
# For elements related to experiment F2
# we artificially produce a gradient of values that will
# create elements with decreasing row means
d[d$experiment =="F2",1:5] <- round(sweep(d[d$experiment =="F2",1:5],
1,
seq(from=10, 1, length.out = 100),
"+"), 2)
#print(d[d$experiment =="F1",1:5])
# Now we split the dataset by experiments
d.split <- split(d, d$experiment)
# For all experiments, we order elements based on the mean expression signal in
# F1.
row.means.F1 <- rowMeans(d.split$F1[,1:5])
pos <- order(row.means.F1)
for(s in names(d.split)){
d.split[[s]] <- d.split[[s]][pos,]
}
## Added: begin ###
#Get the list of elements in proper order (based on row mean)
mean.order <- as.character(d.split$F1$elements)
## Added: end###
# We create several classes of elements based on their
# mean expression signal in F1.
cuts <- cut(1:nrow(d.split$F1), nb.experiment)
levels(cuts) <- sprintf("%02d", 1:nb.experiment)
for(s in names(d.split)){
d.split[[s]] <- split(d.split[[s]], cuts)
}
# Data are melt (their is perhaps a better solution...)
# in order to use the ggplot function
dm <- melt(do.call('rbind',lapply(d.split, melt)), id.var=c( "experiment", "elements", "variable", "L1"))
dm <- dm[, -5]
colnames(dm) <- c("experiment","elements", "pos", "rowMeanClass", "exprs")
## Added: begin###
#Ensure that dm$elements is an ordered factor with levels
# ordered as expected
dm$elements <- factor(dm$elements, levels = mean.order, ordered = TRUE)
## Added: end###
# Now we plot the data
p <- ggplot(dm, aes(x = pos, y = elements, fill = exprs))
p <- p + geom_raster()
p <- p + facet_wrap(~rowMeanClass +experiment , scales = "free", ncol = 2)
p <- p + theme_bw()
p <- p + theme(text = element_text(size=4))
p <- p + theme(text = element_text(family = "mono", face = "bold"))
ggsave("RPlot_test.jpeg", p)
I have a 3D dataset:
data = data.frame(
x = rep( c(0.1, 0.2, 0.3, 0.4, 0.5), each=5),
y = rep( c(1, 2, 3, 4, 5), 5)
)
data$z = runif(
25,
min = (data$x*data$y - 0.1 * (data$x*data$y)),
max = (data$x*data$y + 0.1 * (data$x*data$y))
)
data
str(data)
And I want to plot it, but the built-in-functions of R alwyas give the error
increasing 'x' and 'y' values expected
# ### 3D Plots ######################################################
# built-in function always give the error
# "increasing 'x' and 'y' values expected"
demo(image)
image(x = data$x, y = data$y, z = data$z)
demo(persp)
persp(data$x,data$y,data$z)
contour(data$x,data$y,data$z)
When I searched on the internet, I found that this message happens when combinations of X and Y values are not unique. But here they are unique.
I tried some other libraries and there it works without problems. But I don't like the default style of the plots (the built-in functions should fulfill my expectations).
# ### 3D Scatterplot ######################################################
# Nice plots without surface maps?
install.packages("scatterplot3d", dependencies = TRUE)
library(scatterplot3d)
scatterplot3d(x = data$x, y = data$y, z = data$z)
# ### 3D Scatterplot ######################################################
# Only to play around?
install.packages("rgl", dependencies = TRUE)
library(rgl)
plot3d(x = data$x, y = data$y, z = data$z)
lines3d(x = data$x, y = data$y, z = data$z)
surface3d(x = data$x, y = data$y, z = data$z)
Why are my datasets not accepted by the built-in functions?
I use the lattice package for almost everything I plot in R and it has a corresponing plot to persp called wireframe. Let data be the way Sven defined it.
wireframe(z ~ x * y, data=data)
Or how about this (modification of fig 6.3 in Deepanyan Sarkar's book):
p <- wireframe(z ~ x * y, data=data)
npanel <- c(4, 2)
rotx <- c(-50, -80)
rotz <- seq(30, 300, length = npanel[1]+1)
update(p[rep(1, prod(npanel))], layout = npanel,
panel = function(..., screen) {
panel.wireframe(..., screen = list(z = rotz[current.column()],
x = rotx[current.row()]))
})
Update: Plotting surfaces with OpenGL
Since this post continues to draw attention I want to add the OpenGL way to make 3-d plots too (as suggested by #tucson below). First we need to reformat the dataset from xyz-tripplets to axis vectors x and y and a matrix z.
x <- 1:5/10
y <- 1:5
z <- x %o% y
z <- z + .2*z*runif(25) - .1*z
library(rgl)
persp3d(x, y, z, col="skyblue")
This image can be freely rotated and scaled using the mouse, or modified with additional commands, and when you are happy with it you save it using rgl.snapshot.
rgl.snapshot("myplot.png")
Adding to the solutions of others, I'd like to suggest using the plotly package for R, as this has worked well for me.
Below, I'm using the reformatted dataset suggested above, from xyz-tripplets to axis vectors x and y and a matrix z:
x <- 1:5/10
y <- 1:5
z <- x %o% y
z <- z + .2*z*runif(25) - .1*z
library(plotly)
plot_ly(x=x,y=y,z=z, type="surface")
The rendered surface can be rotated and scaled using the mouse. This works fairly well in RStudio.
You can also try it with the built-in volcano dataset from R:
plot_ly(z=volcano, type="surface")
If you're working with "real" data for which the grid intervals and sequence cannot be guaranteed to be increasing or unique (hopefully the (x,y,z) combinations are unique at least, even if these triples are duplicated), I would recommend the akima package for interpolating from an irregular grid to a regular one.
Using your definition of data:
library(akima)
im <- with(data,interp(x,y,z))
with(im,image(x,y,z))
And this should work not only with image but similar functions as well.
Note that the default grid to which your data is mapped to by akima::interp is defined by 40 equal intervals spanning the range of x and y values:
> formals(akima::interp)[c("xo","yo")]
$xo
seq(min(x), max(x), length = 40)
$yo
seq(min(y), max(y), length = 40)
But of course, this can be overridden by passing arguments xo and yo to akima::interp.
I think the following code is close to what you want
x <- c(0.1, 0.2, 0.3, 0.4, 0.5)
y <- c(1, 2, 3, 4, 5)
zfun <- function(a,b) {a*b * ( 0.9 + 0.2*runif(a*b) )}
z <- outer(x, y, FUN="zfun")
It gives data like this (note that x and y are both increasing)
> x
[1] 0.1 0.2 0.3 0.4 0.5
> y
[1] 1 2 3 4 5
> z
[,1] [,2] [,3] [,4] [,5]
[1,] 0.1037159 0.2123455 0.3244514 0.4106079 0.4777380
[2,] 0.2144338 0.4109414 0.5586709 0.7623481 0.9683732
[3,] 0.3138063 0.6015035 0.8308649 1.2713930 1.5498939
[4,] 0.4023375 0.8500672 1.3052275 1.4541517 1.9398106
[5,] 0.5146506 1.0295172 1.5257186 2.1753611 2.5046223
and a graph like
persp(x, y, z)
Not sure why the code above did not work for the library rgl, but the following link has a great example with the same library.
Run the code in R and you will obtain a beautiful 3d plot that you can turn around in all angles.
http://statisticsr.blogspot.de/2008/10/some-r-functions.html
########################################################################
## another example of 3d plot from my personal reserach, use rgl library
########################################################################
# 3D visualization device system
library(rgl);
data(volcano)
dim(volcano)
peak.height <- volcano;
ppm.index <- (1:nrow(volcano));
sample.index <- (1:ncol(volcano));
zlim <- range(peak.height)
zlen <- zlim[2] - zlim[1] + 1
colorlut <- terrain.colors(zlen) # height color lookup table
col <- colorlut[(peak.height-zlim[1]+1)] # assign colors to heights for each point
open3d()
ppm.index1 <- ppm.index*zlim[2]/max(ppm.index);
sample.index1 <- sample.index*zlim[2]/max(sample.index)
title.name <- paste("plot3d ", "volcano", sep = "");
surface3d(ppm.index1, sample.index1, peak.height, color=col, back="lines", main = title.name);
grid3d(c("x", "y+", "z"), n =20)
sample.name <- paste("col.", 1:ncol(volcano), sep="");
sample.label <- as.integer(seq(1, length(sample.name), length = 5));
axis3d('y+',at = sample.index1[sample.label], sample.name[sample.label], cex = 0.3);
axis3d('y',at = sample.index1[sample.label], sample.name[sample.label], cex = 0.3)
axis3d('z',pos=c(0, 0, NA))
ppm.label <- as.integer(seq(1, length(ppm.index), length = 10));
axes3d('x', at=c(ppm.index1[ppm.label], 0, 0), abs(round(ppm.index[ppm.label], 2)), cex = 0.3);
title3d(main = title.name, sub = "test", xlab = "ppm", ylab = "samples", zlab = "peak")
rgl.bringtotop();
imagine I have a 3 columns matrix
x, y, z
where z is a function of x and y.
I know how to plot a "scatter plot" of these points with
plot3d(x,y,z)
But if I want a surface instead I must use other commands such as surface3d
The problem is that it doesn't accept the same inputs as plot3d
it seems to need a matrix with
(nº elements of z) = (n of elements of x) * (n of elements of x)
How can I get this matrix?
I've tried with the command interp, as I do when I need to use contour plots.
How can I plot a surface directly from x,y,z without calculating this matrix?
If I had too many points this matrix would be too big.
cheers
If your x and y coords are not on a grid then you need to interpolate your x,y,z surface onto one. You can do this with kriging using any of the geostatistics packages (geoR, gstat, others) or simpler techniques such as inverse distance weighting.
I'm guessing the 'interp' function you mention is from the akima package. Note that the output matrix is independent of the size of your input points. You could have 10000 points in your input and interpolate that onto a 10x10 grid if you wanted. By default akima::interp does it onto a 40x40 grid:
require(akima)
require(rgl)
x = runif(1000)
y = runif(1000)
z = rnorm(1000)
s = interp(x,y,z)
> dim(s$z)
[1] 40 40
surface3d(s$x,s$y,s$z)
That'll look spiky and rubbish because its random data. Hopefully your data isnt!
You can use the function outer() to generate it.
Have a look at the demo for the function persp(), which is a base graphics function to draw perspective plots for surfaces.
Here is their first example:
x <- seq(-10, 10, length.out = 50)
y <- x
rotsinc <- function(x,y) {
sinc <- function(x) { y <- sin(x)/x ; y[is.na(y)] <- 1; y }
10 * sinc( sqrt(x^2+y^2) )
}
z <- outer(x, y, rotsinc)
persp(x, y, z)
The same applies to surface3d():
require(rgl)
surface3d(x, y, z)
You could look at using Lattice. In this example I have defined a grid over which I want to plot z~x,y. It looks something like this. Note that most of the code is just building a 3D shape that I plot using the wireframe function.
The variables "b" and "s" could be x or y.
require(lattice)
# begin generating my 3D shape
b <- seq(from=0, to=20,by=0.5)
s <- seq(from=0, to=20,by=0.5)
payoff <- expand.grid(b=b,s=s)
payoff$payoff <- payoff$b - payoff$s
payoff$payoff[payoff$payoff < -1] <- -1
# end generating my 3D shape
wireframe(payoff ~ s * b, payoff, shade = TRUE, aspect = c(1, 1),
light.source = c(10,10,10), main = "Study 1",
scales = list(z.ticks=5,arrows=FALSE, col="black", font=10, tck=0.5),
screen = list(z = 40, x = -75, y = 0))
rgl is great, but takes a bit of experimentation to get the axes right.
If you have a lot of points, why not take a random sample from them, and then plot the resulting surface. You can add several surfaces all based on samples from the same data to see if the process of sampling is horribly affecting your data.
So, here is a pretty horrible function but it does what I think you want it to do (but without the sampling). Given a matrix (x, y, z) where z is the heights it will plot both the points and also a surface. Limitations are that there can only be one z for each (x,y) pair. So planes which loop back over themselves will cause problems.
The plot_points = T will plot the individual points from which the surface is made - this is useful to check that the surface and the points actually meet up. The plot_contour = T will plot a 2d contour plot below the 3d visualization. Set colour to rainbow to give pretty colours, anything else will set it to grey, but then you can alter the function to give a custom palette. This does the trick for me anyway, but I'm sure that it can be tidied up and optimized. The verbose = T prints out a lot of output which I use to debug the function as and when it breaks.
plot_rgl_model_a <- function(fdata, plot_contour = T, plot_points = T,
verbose = F, colour = "rainbow", smoother = F){
## takes a model in long form, in the format
## 1st column x
## 2nd is y,
## 3rd is z (height)
## and draws an rgl model
## includes a contour plot below and plots the points in blue
## if these are set to TRUE
# note that x has to be ascending, followed by y
if (verbose) print(head(fdata))
fdata <- fdata[order(fdata[, 1], fdata[, 2]), ]
if (verbose) print(head(fdata))
##
require(reshape2)
require(rgl)
orig_names <- colnames(fdata)
colnames(fdata) <- c("x", "y", "z")
fdata <- as.data.frame(fdata)
## work out the min and max of x,y,z
xlimits <- c(min(fdata$x, na.rm = T), max(fdata$x, na.rm = T))
ylimits <- c(min(fdata$y, na.rm = T), max(fdata$y, na.rm = T))
zlimits <- c(min(fdata$z, na.rm = T), max(fdata$z, na.rm = T))
l <- list (x = xlimits, y = ylimits, z = zlimits)
xyz <- do.call(expand.grid, l)
if (verbose) print(xyz)
x_boundaries <- xyz$x
if (verbose) print(class(xyz$x))
y_boundaries <- xyz$y
if (verbose) print(class(xyz$y))
z_boundaries <- xyz$z
if (verbose) print(class(xyz$z))
if (verbose) print(paste(x_boundaries, y_boundaries, z_boundaries, sep = ";"))
# now turn fdata into a wide format for use with the rgl.surface
fdata[, 2] <- as.character(fdata[, 2])
fdata[, 3] <- as.character(fdata[, 3])
#if (verbose) print(class(fdata[, 2]))
wide_form <- dcast(fdata, y ~ x, value_var = "z")
if (verbose) print(head(wide_form))
wide_form_values <- as.matrix(wide_form[, 2:ncol(wide_form)])
if (verbose) print(wide_form_values)
x_values <- as.numeric(colnames(wide_form[2:ncol(wide_form)]))
y_values <- as.numeric(wide_form[, 1])
if (verbose) print(x_values)
if (verbose) print(y_values)
wide_form_values <- wide_form_values[order(y_values), order(x_values)]
wide_form_values <- as.numeric(wide_form_values)
x_values <- x_values[order(x_values)]
y_values <- y_values[order(y_values)]
if (verbose) print(x_values)
if (verbose) print(y_values)
if (verbose) print(dim(wide_form_values))
if (verbose) print(length(x_values))
if (verbose) print(length(y_values))
zlim <- range(wide_form_values)
if (verbose) print(zlim)
zlen <- zlim[2] - zlim[1] + 1
if (verbose) print(zlen)
if (colour == "rainbow"){
colourut <- rainbow(zlen, alpha = 0)
if (verbose) print(colourut)
col <- colourut[ wide_form_values - zlim[1] + 1]
# if (verbose) print(col)
} else {
col <- "grey"
if (verbose) print(table(col2))
}
open3d()
plot3d(x_boundaries, y_boundaries, z_boundaries,
box = T, col = "black", xlab = orig_names[1],
ylab = orig_names[2], zlab = orig_names[3])
rgl.surface(z = x_values, ## these are all different because
x = y_values, ## of the confusing way that
y = wide_form_values, ## rgl.surface works! - y is the height!
coords = c(2,3,1),
color = col,
alpha = 1.0,
lit = F,
smooth = smoother)
if (plot_points){
# plot points in red just to be on the safe side!
points3d(fdata, col = "blue")
}
if (plot_contour){
# plot the plane underneath
flat_matrix <- wide_form_values
if (verbose) print(flat_matrix)
y_intercept <- (zlim[2] - zlim[1]) * (-2/3) # put the flat matrix 1/2 the distance below the lower height
flat_matrix[which(flat_matrix != y_intercept)] <- y_intercept
if (verbose) print(flat_matrix)
rgl.surface(z = x_values, ## these are all different because
x = y_values, ## of the confusing way that
y = flat_matrix, ## rgl.surface works! - y is the height!
coords = c(2,3,1),
color = col,
alpha = 1.0,
smooth = smoother)
}
}
The add_rgl_model does the same job without the options, but overlays a surface onto the existing 3dplot.
add_rgl_model <- function(fdata){
## takes a model in long form, in the format
## 1st column x
## 2nd is y,
## 3rd is z (height)
## and draws an rgl model
##
# note that x has to be ascending, followed by y
print(head(fdata))
fdata <- fdata[order(fdata[, 1], fdata[, 2]), ]
print(head(fdata))
##
require(reshape2)
require(rgl)
orig_names <- colnames(fdata)
#print(head(fdata))
colnames(fdata) <- c("x", "y", "z")
fdata <- as.data.frame(fdata)
## work out the min and max of x,y,z
xlimits <- c(min(fdata$x, na.rm = T), max(fdata$x, na.rm = T))
ylimits <- c(min(fdata$y, na.rm = T), max(fdata$y, na.rm = T))
zlimits <- c(min(fdata$z, na.rm = T), max(fdata$z, na.rm = T))
l <- list (x = xlimits, y = ylimits, z = zlimits)
xyz <- do.call(expand.grid, l)
#print(xyz)
x_boundaries <- xyz$x
#print(class(xyz$x))
y_boundaries <- xyz$y
#print(class(xyz$y))
z_boundaries <- xyz$z
#print(class(xyz$z))
# now turn fdata into a wide format for use with the rgl.surface
fdata[, 2] <- as.character(fdata[, 2])
fdata[, 3] <- as.character(fdata[, 3])
#print(class(fdata[, 2]))
wide_form <- dcast(fdata, y ~ x, value_var = "z")
print(head(wide_form))
wide_form_values <- as.matrix(wide_form[, 2:ncol(wide_form)])
x_values <- as.numeric(colnames(wide_form[2:ncol(wide_form)]))
y_values <- as.numeric(wide_form[, 1])
print(x_values)
print(y_values)
wide_form_values <- wide_form_values[order(y_values), order(x_values)]
x_values <- x_values[order(x_values)]
y_values <- y_values[order(y_values)]
print(x_values)
print(y_values)
print(dim(wide_form_values))
print(length(x_values))
print(length(y_values))
rgl.surface(z = x_values, ## these are all different because
x = y_values, ## of the confusing way that
y = wide_form_values, ## rgl.surface works!
coords = c(2,3,1),
alpha = .8)
# plot points in red just to be on the safe side!
points3d(fdata, col = "red")
}
So my approach would be to, try to do it with all your data (I easily plot surfaces generated from ~15k points). If that doesn't work, take several smaller samples and plot them all at once using these functions.
Maybe is late now but following Spacedman, did you try duplicate="strip" or any other option?
x=runif(1000)
y=runif(1000)
z=rnorm(1000)
s=interp(x,y,z,duplicate="strip")
surface3d(s$x,s$y,s$z,color="blue")
points3d(s)