I have data interpolated on a grid and I need to retrieve the iso-contour coordinates:
require(akima)
require(pracma)
require(ggplot2)
require(RColorBrewer)
r <- seq(0.1, 1, length.out = 20)
theta <- seq(0, 90)
my.df <- expand.grid(r = r, theta = theta)
my.df$value <- 1/my.df$r^2 * sin(deg2rad(my.df$theta))
# Interpolating data on rectangular grid
data.interp <-
interp(
x = my.df$r * cos(deg2rad(my.df$theta)),
y = my.df$r * sin(deg2rad(my.df$theta)),
z = my.df$value,
nx = 200,
ny = 200,
duplicate = "strip"
)
data.xyz <- as.data.frame(interp2xyz(data.interp))
data.xyz <- setNames(data.xyz, c("x", "y", "value"))
data.xyz <- na.omit(data.xyz)
my.breaks <- c(0, 10, 20, 30, 40, 50, 60, 70, 80, 90, 100)
brks <- cut(data.xyz$value,
breaks = my.breaks,
ordered_result = TRUE)
levels(brks) <- gsub(",", " - ", levels(brks), fixed = TRUE)
levels(brks) <- gsub("\\(|\\]","",levels(brks))
data.xyz$brks <- brks
ggplot(data.xyz, aes(x = x, y = y, fill = brks)) +
geom_tile() +
scale_fill_manual("Value",
values = rev(colorRampPalette(brewer.pal(11, "Spectral"))(length(my.breaks))))
Here is what the result looks like:
What I need is to retrieve the coordinates of my iso-contours.
The purpose of to create a 3D model of those contours assuming the data is axisymmetric. But before I do that, I need to find the coordinates of the line separating the colors.
Using contourLines, here is how to do this:
r <- seq(0.1, 1, length.out = 20)
theta <- seq(0, 90)
my.df <- expand.grid(r = r, theta = theta)
my.df$value <- 1/my.df$r^2 * sin(deg2rad(my.df$theta))
my.matrix <- acast(my.df, r ~ theta, value.var = "value")
contour.lines <- contourLines(x = r,
y = theta,
z = my.matrix,
levels = seq(0, 100, by = 10))
contour.df <- data.frame()
for(level in contour.lines) {
contour.df <- rbind(contour.df, data.frame(x = level$x * cos(deg2rad(level$y)),
y = level$x * sin(deg2rad(level$y)),
level = as.factor(level$level)))
}
ggplot(contour.df, aes(x, y, color = level)) + geom_path() + scale_x_continuous(limits = c(0, 1)) + scale_y_continuous(limits = c(0, 1))
Related
I would like to bin two columns of a dataset simultaneously to create one common binned column. The simple code is as follows
x <- sample(100)
y <- sample(100)
data <- data.frame(x, y)
xbin <- seq(from = 0, to = 100, by = 10)
ybin <- seq(from = 0, to = 100, by = 10)
Any help is appreciated!
Not sure if this is what you are looking for
library(tidyverse)
x <- sample(100)
y <- sample(100)
data <- data.frame(x, y)
xbin <- seq(from = 0, to = 100, by = 10)
ybin <- seq(from = 0, to = 100, by = 10)
data <- data%>%
dplyr::mutate(
x_binned = cut(x, breaks = seq(0,100,10)),
y_binned = cut(y, breaks = seq(0,100,10))
)
data %>%
ggplot() +
geom_bin_2d(
aes(x = x_binned, y = y_binned), binwidth = c(10,10), colour = "red") +
theme_minimal()
After asking in the comments I am still not quite shure, what the desired answer would look like but I hope, that one of the two answers in the below code will work for you:
x <- sample(100)
y <- sample(100)
data <- data.frame(x, y)
xbin <- seq(from = 0, to = 100, by = 10)
ybin <- seq(from = 0, to = 100, by = 10)
data$xbin <- cut(data$x, breaks = xbin, ordered = TRUE)
data$ybin <- cut(data$y, breaks = ybin, ordered = TRUE)
data$commonbin1 <- paste0(data$xbin, data$ybin)
data$commonbin2 <- paste0("(",as.numeric(data$xbin),";", as.numeric(data$ybin),")")
head(data, 20)
This will construct a common binning variable commonbin1 that includes the bin-limits in the names of the bins and commonbin2 which will be easier to compare to the plot mentioned in the comment.
I'm trying to make a figure similar to this in R. Basically X and Y represent coordinates (e.g. lon/lat) and Z represents elevation. I want to plot a 3D bar chart with a elevation as the bar height, and then show a smooth curve of fitted Z values going through the bars. I am able to get a 3d barplot with barplot3d but I'm not sure if it's possible to add the fitted curve on top of that. Does anyone know how to do this? I have some example code below demonstrating what I've tried so far.
library(rgl)
library(barplot3d)
library(tidyverse)
x_mat<- matrix(rep(-1:1, each=3),nrow = 3) #x coordinates
y_mat<- matrix(rev(rep(-1:1, each=3)),nrow = 3, byrow = TRUE) #y coordinates
df<- data.frame(x = as.vector(x_mat), y = as.vector(y_mat)) #dataframe
set.seed(5)
df<- df %>% mutate(z= x^2+ y^2 + rnorm(n = 9, mean = 0, sd = 0.1)) #add elevation values
m<- lm(z ~ I(x^2)+I(y^2)+I(x*y)+x+y, data = df) #fitted curve
rgl.open()
rgl::plot3d(m)
barplot3d(rows=3,cols=3, z=df$z,scalexy=1, gap=0, alpha=0.4,theta=30,phi=50,
topcolors = "gray", gridlines = TRUE)
Update: More complicated example
The curve doesn't seem to intersect the bars properly with current solution for a non-symmetrical curve (fixed in most updated answer).
library(rgl)
library(barplot3d)
library(tidyverse)
x_mat<- matrix(rep(-1:1, each=3),nrow = 3) #x coordinates
y_mat<- matrix(rev(rep(-1:1, each=3)),nrow = 3, byrow = TRUE) #y coordinates
A<- 0.2
B<- 0.2
C<- 0.4
D<- 0.4
E<- 0
df<- data.frame(x = as.vector(x_mat), y = as.vector(y_mat)) #dataframe
df<- df %>% mutate(z= A*x^2 + B*y^2 + C*x*y + D*x + E*y) #add elevation values
z_mat<- matrix(data = df$z, nrow=3)
m<- lm(z ~ I(x^2)+I(y^2)+I(x*y)+x+y, data = df) #fitted curve
df$zpred<- predict(m, data.frame(x=df$x, y=df$y))
round(df$z-df$zpred,10) #Predictions should fit observations almost exactly (i.e. intersect exactly with bars)
#0 0 0 0 0 0 0 0 0
n<- 10
xvals <- seq(-1, 1, len = n)
xmat <- replicate(n, seq(1.5, 3.5, len = n))
ymat <- t(xmat)
pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), nrow = n, ncol = n)
barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
topcolors = "gray", sidecolors = "cyan", linecolors= "blue", gridlines = FALSE, zlabels = FALSE)
surface3d(x = xmat, y = zmat, z = ymat-5, color = "purple", alpha = 0.7)
axes3d()
As you can probably tell, your 3d surface is rotated 90 degrees relative to where it should be. This is not your fault; it is just a difference between the way barplot3d is drawn compared to the other rgl shapes. You also need a bit of shifting and rescaling to get it to fit.
barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
topcolors = "gray", gridlines = TRUE)
xvals <- seq(-1.5, 1.5, len = 10)
xmat <- replicate(10, seq(1, 4, len = 10))
ymat <- t(xmat)
pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), 10, 10)
surface3d(xmat, zmat, color = "gold", alpha = 0.5, ymat - 5)
Update
To remove the points above the highest bar, just set them to NA. You probably want to increase the resolution when you do this though:
xvals <- seq(-1.5, 1.5, len = 100)
xmat <- replicate(100, seq(1, 4, len = 100))
ymat <- t(xmat) - 5
pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), 100, 100)
zmat[zmat > 2] <- NA
barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
topcolors = "gray", gridlines = TRUE)
surface3d(xmat, zmat, color = "gold", alpha = 0.5, ymat)
Note that this gives an unavoidably ragged edge to the graphic
An alternative is to shrink the x, y grids at which z is calculated:
xvals <- seq(-1, 1, len = 100)
xmat <- replicate(100, seq(1.5, 3.5, len = 100))
ymat <- t(xmat) - 5
pred <- expand.grid(x = xvals, y = xvals)
zmat <- matrix(predict(m, pred), 100, 100)
barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
topcolors = "gray", gridlines = TRUE)
surface3d(xmat, zmat, ymat, color = "gray20", alpha = 0.5)
Further update
It looks as though we need a double flip to get the z values correct:
barplot3d(rows=3,cols=3, z=df$z, gap=0, alpha=0.4, phi = 45,
topcolors = "gray", sidecolors = "cyan", linecolors= "blue",
gridlines = FALSE, zlabels = FALSE)
surface3d(x = xmat, y = t(apply(t(apply(zmat, 1, rev)), 2, rev)),
z = ymat-5, color = "purple", alpha = 0.7)
axes3d()
How can I have 3 2-Dimensional slices (x, y; x, z; y, z) in a 3-Dimensional coordinate system which are heatmaps. Each square in the slices should have a color which is given by the output from a formula. So it should look like this but in plotly or R and with specifically generated data for the colors (not randomized): source - python example
You can use plotly in R to draw surface plots, but as far as I can tell the surfaces will always be interpolated:
Suppose your x, y and z outputs are given by three different functions:
fun1 <- function(x, y) {
sqrt(x^2 + y^2)
}
fun2 <- function(x, y) {
rnorm(seq_along(x))
}
fun3 <- function(x, y) {
x + y
}
Then you can create the necessary outputs by doing:
xvals <- seq(0.01, 1, 0.01)
yvals <- seq(0.01, 1, 0.01)
df <- expand.grid(x = xvals, y = yvals)
df$f1 <- c(outer(xvals, yvals, fun1))
df$f2 <- c(outer(xvals, yvals, fun2))
df$f3 <- c(outer(xvals, yvals, fun3))
df$f1 <- ave(df$f1, floor(df$x * 10)/10, floor(df$y * 10)/10)
df$f2 <- ave(df$f2, floor(df$x * 10)/10, floor(df$y * 10)/10)
df$f3 <- ave(df$f3, floor(df$x * 10)/10, floor(df$y * 10)/10)
library(plotly)
plot_ly(df) %>%
add_surface(z = matrix(0.75, 100, 100), x=matrix(df$x, 100, 100),
y = matrix(df$y, 100, 100), colorscale = 'Rainbow',
surfacecolor = ~matrix(df$f1, 100, 100)) %>%
add_surface(z = matrix(df$y, 100, 100), x = matrix(df$x, 100, 100),
y = matrix(0.5, 100, 100), colorscale = 'Rainbow',
surfacecolor = ~matrix(df$f2, 100, 100)) %>%
add_surface(z = ~matrix(df$y, 100, 100), x = matrix(0.5, 100, 100),
y = matrix(df$x, 100, 100), colorscale = 'Rainbow',
surfacecolor = ~matrix(df$f3, 100, 100))
I have been trying to fill Voronoi polygons/tiles with raster grob objects, but I have not been able to find a way to do it. This is a sample of the code for the Voronoi ggplot
library(ggplot2)
library(grid)
library(RColorBrewer)
library(ggmap)
library(ggvoronoi)
library(raster)
# Get the location of the city in the map
bcn_map <- get_googlemap(center = "Plaza España, Barcelona",zoom = 14,key="xxx")
bounds <- as.numeric(attr(bcn_map,"bb"))
set.seed(500)
num <- geocode("Plaza España, Barcelona")
# Create a dummy data frame with random values
df <- round(data.frame(
x = jitter(rep(num$lon,200), amount = .03),
y = jitter(rep( num$lat,200), amount = .03)
), digits = 5)
# Plot the map with the Voronoi layer
ggmap(bcn_map,base_layer = ggplot(data=df,aes(x,y))) +
coord_map(ylim=bounds[c(1,3)],xlim=bounds[c(2,4)]) +
theme_minimal() +
theme(axis.text=element_blank(),
axis.title=element_blank())+
geom_path(stat="voronoi",alpha=0.2 ,size=2,colour = "pink") +
geom_point(color="blue",size=.25)
And this is the raster object I want to include, fitting the tiles in the Voronoi diagram:
make_gradient <- function(deg = 45, n = 100, cols = blues9) {
cols <- colorRampPalette(cols)(n + 1)
rad <- deg / (180 / pi)
mat <- matrix(
data = rep(seq(0, 1, length.out = n) * cos(rad), n),
byrow = TRUE,
ncol = n
) +
matrix(
data = rep(seq(0, 1, length.out = n) * sin(rad), n),
byrow = FALSE,
ncol = n
)
mat <- mat - min(mat)
mat <- mat / max(mat)
mat <- 1 + mat * n
mat <- matrix(data = cols[round(mat)], ncol = n)
grid::rasterGrob(
image = mat,
width = unit(1, "npc"),
height = unit(1, "npc"),
interpolate = TRUE
)
}
#Set pallete
cc <- palette(c("#333C83","#F24A72","white","#FDAF75"))
# Create gradient with the colors defined before
raster.grob <- make_gradient(
deg = 90, n = 100, cols = cc
)
I don't know if this is possible in R, but thanks in advance for the help.
I am trying to output multiple density plot from a function, by dividing the dataframe into pieces such that separate density for each level of a factor for corresponding yvar.
set.seed(1234)
Aa = c(rnorm(40000, 50, 10))
Bb = c(rnorm(4000, 70, 10))
Cc = c(rnorm(400, 75, 10))
Dd = c(rnorm(40, 80, 10))
yvar = c(Aa, Bb, Cc, Dd)
gen <- c(rep("Aa", length(Aa)),rep("Bb", length(Bb)), rep("Cc", length(Cc)),
rep("Dd", length(Dd)))
mydf <- data.frame(gen, yvar)
minyvar <- min(yvar)
maxyvar <- max(yvar)
par(mfrow = c(length(levels(mydf$gen)),1))
plotdensity <- function (xf, minyvar, maxyvar){
plot(density(xf), xlim=c(minyvar, maxyvar), main = paste (names(xf),
"distribution", sep = ""))
dens <- density(xf)
x1 <- min(which(dens$x >= quantile(xf, .80)))
x2 <- max(which(dens$x < max(dens$x)))
with(dens, polygon(x=c(x[c(x1,x1:x2,x2)]), y= c(0, y[x1:x2], 0), col="blu4"))
abline(v= mean(xf), col = "black", lty = 1, lwd =2)
}
require(plyr)
ddply(mydf, .(mydf$gen), plotdensity, yvar, minyvar, maxyvar)
Error in .fun(piece, ...) : unused argument(s) (111.544494112914)
My specific expectation are each plot is named by name of level for example Aa, Bb, Cc, Dd
Arrangement of the graphs see the parameter set, so that we compare density changes and means. compact - Low space between the graphs.
Help appreciated.
Edits:
The following graphs are individually produced, although I want to develop a function that can be applicable to x level for a factor.
I see that #Andrie just beat me to most of this. I'm still going to post my answer, since filling only certain quantiles of the distribution requires a slightly different approach.
set.seed(1234)
Aa = c(rnorm(40000, 50, 10))
Bb = c(rnorm(4000, 70, 10))
Cc = c(rnorm(400, 75, 10))
Dd = c(rnorm(40, 80, 10))
yvar = c(Aa, Bb, Cc, Dd)
gen <- c(rep("Aa", length(Aa)),rep("Bb", length(Bb)), rep("Cc", length(Cc)),
rep("Dd", length(Dd)))
mydf <- data.frame(grp = gen,x = c(Aa,Bb,Cc,Dd))
#Calculate the densities and an indicator for the desire quantile
# for later use in subsetting
mydf <- ddply(mydf,.(grp),.fun = function(x){
tmp <- density(x$x)
x1 <- tmp$x
y1 <- tmp$y
q80 <- x1 >= quantile(x$x,0.8)
data.frame(x=x1,y=y1,q80=q80)
})
#Separate data frame for the means
mydfMean <- ddply(mydf,.(grp),summarise,mn = mean(x))
ggplot(mydf,aes(x = x)) +
facet_wrap(~grp) +
geom_line(aes(y = y)) +
geom_ribbon(data = subset(mydf,q80),aes(ymax = y),ymin = 0, fill = "black") +
geom_vline(data = mydfMean,aes(xintercept = mn),colour = "black")
Here is a way of doing it in ggplot:
set.seed(1234)
mydf <- rbind(
data.frame(gen="Aa", yvar= rnorm(40000, 50, 10)),
data.frame(gen="Bb", yvar=rnorm(4000, 70, 10)),
data.frame(gen="Cc", yvar=rnorm(400, 75, 10)),
data.frame(gen="Dd", yvar=rnorm(40, 80, 10))
)
labels <- ddply(mydf, .(gen), nrow)
means <- ddply(mydf, .(gen), summarize, mean=mean(yvar))
ggplot(mydf, aes(x=yvar)) +
stat_density(fill="blue") +
facet_grid(gen~.) +
theme_bw() +
geom_vline(data=means, aes(xintercept=mean), colour="red") +
geom_text(data=labels, aes(label=paste("n =", V1)), x=5, y=0,
hjust=0, vjust=0) +
opts(title="Distribution")
With sincere thanks to joran and Andrie, the following is just compilation of my favorite from above two posts, just some of readers might want to see.
require(ggplot2)
set.seed(1234)
Aa = c(rnorm(40000, 50, 10))
Bb = c(rnorm(4000, 70, 10))
Cc = c(rnorm(400, 75, 10))
Dd = c(rnorm(40, 80, 10))
yvar = c(Aa, Bb, Cc, Dd)
gen <- c(rep("Aa", length(Aa)),rep("Bb", length(Bb)), rep("Cc", length(Cc)),
rep("Dd", length(Dd)))
mydf <- data.frame(grp = gen,x = c(Aa,Bb,Cc,Dd))
mydf1 <- mydf
#Calculate the densities and an indicator for the desire quantile
# for later use in subsetting
mydf <- ddply(mydf,.(grp),.fun = function(x){
tmp <- density(x$x)
x1 <- tmp$x
y1 <- tmp$y
q80 <- x1 >= quantile(x$x,0.8)
data.frame(x=x1,y=y1,q80=q80)
})
#Separate data frame for the means
mydfMean <- ddply(mydf,.(grp),summarise,mn = mean(x))
labels <- ddply(mydf1, .(grp), nrow)
ggplot(mydf,aes(x = x)) +
facet_grid(grp~.) +
geom_line(aes(y = y)) +
geom_ribbon(data = subset(mydf,q80),aes(ymax = y),ymin = 0,
fill = "black") +
geom_vline(data = mydfMean,aes(xintercept = mn),
colour = "black") + geom_text(data=labels,
aes(label=paste("n =", labels$V1)), x=5, y=0,
hjust=0, vjust=0) +
opts(title="Distribution") + theme_bw()