I am trying to get two contours in the same plot using ggplot2 in R.
Here is a reproducible example:
library(MASS)
library(ggplot2)
# first contour
m <- c(.0, -.0)
sigma <- matrix(c(1,.5,.5,1), nrow=2)
data.grid <- expand.grid(s.1 = seq(-3, 3, length.out=200), s.2 = seq(-3, 3, length.out=200))
q.samp <- cbind(data.grid, prob = mvtnorm::dmvnorm(data.grid, mean = m, sigma = sigma))
plot1 <- ggplot(q.samp, aes(x = s.1, y = s.2, z = prob)) +
stat_contour(color = 'green')
# second contour
m1 <- c(1, 1)
sigma1 <- matrix(c(1,-.5,-.5,1), nrow=2)
set.seed(10)
data.grid1 <- expand.grid(s.1 = seq(-3, 3, length.out=200), s.2 = seq(-3, 3, length.out=200))
q.samp1 <- cbind(data.grid1, prob = mvtnorm::dmvnorm(data.grid1, mean = m1, sigma = sigma1))
plot2 <- ggplot(q.samp1, aes(x = s.1, y = s.2, z = prob)) +
stat_contour(color = 'red')
However, trying plot1 + plot2 also does not work. Is there a way to get the two contours on the same plot.
What about including another stat_contour with different data?
ggplot(q.samp1, aes(x = s.1, y = s.2, z = prob)) +
stat_contour(color = 'red') +
stat_contour(data = q.samp, aes(x = s.1, y = s.2, z = prob), color = 'green')
Related
I'd like to change the color of the contour curve from z variable. My MWE can be seen below.
library(ggplot2)
library(tidyverse)
rosenbrock <- function(x){
d <- length(x)
out <- 0
for(i in 1 : (d - 1)){
out <- out + 100 * ( x[i]^2 - x[i + 1] )^2 + (x[i] - 1)^2
}
out
}
set.seed(1)
coord <- matrix(runif(2000, -50, 50), byrow = TRUE, ncol = 2)
graph <- apply(coord, 1, rosenbrock)
results <- data.frame(x = coord[, 1], y = coord[, 2], z = graph) %>%
arrange(x, y)
set.seed(2020)
n <- 5
x1 <- matrix(c(round(rnorm(n, -12, 5), 2), 0, round(rnorm(n, -6, 5), 2), 0), byrow = F, ncol = 2)
y1 <- apply(x1, 1, function(x) rosenbrock(x))
test_points <- data.frame(x = x1[, 1], y = x1[, 2],
z = y1)
results %>%
ggplot(aes(x = x, y = y, z = z)) +
stat_density2d() +
geom_point(data = test_points, aes(colour = z), size = 2.0, shape = 19) +
scale_colour_gradientn(colours=rainbow(4)) +
theme_light() +
labs(colour = 'Fitness')
Something like this?
results %>%
ggplot(aes(x = x, y = y, z = z)) +
stat_density2d(aes(fill = stat(level)), geom = "polygon") +
geom_point(data = test_points, aes(colour = z), size = 2.0, shape = 19) +
scale_colour_gradientn(colours=rainbow(4)) +
theme_light() +
labs(colour = 'Fitness')
The last few examples at https://ggplot2.tidyverse.org/reference/geom_density_2d.html might be what you're looking for
I am relatively new to R. I would like to know how to create the following graphic. I have been stuck for over two hours.
Suppose the red line - the true relationship - is y = x^2.
Suppose I want to fit 100 linear models to 100 random samples (blue lines).
How would I do this? So far, this is what I have:
# create the true relationship
f <- function(x) x^2 # true model
x <- seq(0, 1, by = 0.01)
y <- f(x)
# plot the true function
plot(x, y, type = "l", col = "red", ylim = c(-0.2, 1.2), lwd = 4)
# fit 100 models
set.seed(1)
for (i in 1:100)
{
errors <- rnorm(n, 0, sigma) # random errors, have standard deviation sigma
obs_y <- f(obs_x) + errors # observed y = true_model + error
model <- lm(obs_y ~ obs_x) # fit a linear model to the observed values
points(obs_x[i], mean(obs_y[i]), col = "green") # mean values
abline(model, col = "purple") # plot the fitted model
}
which creates this:
in which the green dots are definitely off...
and I don't have the black dots...
Thanks!
Here's your code after several adjustments:
f <- function(x) x^2
x <- seq(0, 1, by = 0.05)
n <- length(x)
sigma <- 0.05
y <- f(x)
plot(x, y, type = "l", col = "red", ylim = c(-0.2, 1.2), lwd = 2)
fitted <- ys <- matrix(0, ncol = n, nrow = 100)
set.seed(1)
for (i in 1:100)
{
errors <- rnorm(n, 0, sigma)
ys[i, ] <- obs_y <- f(x) + errors
model <- lm(obs_y ~ x)
fitted[i, ] <- fitted(model)
abline(model, col = "purple", lwd = 0.1)
}
points(x = rep(x, each = 100), y = ys, cex = 0.1)
points(x = x, y = colMeans(fitted), col = 'green', cex = 0.3)
With ggplot, e.g.
library(ggplot2)
x <- seq(0, 1, 0.1)
y <- x^2
dat <- as.data.frame(do.call(rbind, lapply(1:100, function(i){
y_err <- y + rnorm(1, 0, 0.06)
l <- lm(y_err ~ x)$coefficients
cbind(samp = i, intercept = l[1], slope = l[2], t(x * l[2] + l[1]), t(y_err))
})), row.names = 1:100)
ggplot() +
geom_abline(aes(intercept = dat$intercept, slope = dat$slope)) +
geom_point(aes(x = rep(x, each = 100), y = unlist(dat[, 15:25])), alpha = 0.5) +
geom_line(aes(x = x, y = y), color = "red", lwd = 2) +
geom_point(aes(x = x, y = colMeans(dat[, 4:14])), color = "green")
I have two populations A and B distributed spatially with one character Z, I want to be able to make an hexbin substracting the proportion of the character in each hexbin. Here I have the code for two theoretical populations A and B
library(hexbin)
library(ggplot2)
set.seed(2)
xA <- rnorm(1000)
set.seed(3)
yA <- rnorm(1000)
set.seed(4)
zA <- sample(c(1, 0), 20, replace = TRUE, prob = c(0.2, 0.8))
hbinA <- hexbin(xA, yA, xbins = 40, IDs = TRUE)
A <- data.frame(x = xA, y = yA, z = zA)
set.seed(5)
xB <- rnorm(1000)
set.seed(6)
yB <- rnorm(1000)
set.seed(7)
zB <- sample(c(1, 0), 20, replace = TRUE, prob = c(0.4, 0.6))
hbinB <- hexbin(xB, yB, xbins = 40, IDs = TRUE)
B <- data.frame(x = xB, y = yB, z = zB)
ggplot(A, aes(x, y, z = z)) + stat_summary_hex(fun = function(z) sum(z)/length(z), alpha = 0.8) +
scale_fill_gradientn(colours = c("blue","red")) +
guides(alpha = FALSE, size = FALSE)
ggplot(B, aes(x, y, z = z)) + stat_summary_hex(fun = function(z) sum(z)/length(z), alpha = 0.8) +
scale_fill_gradientn (colours = c("blue","red")) +
guides(alpha = FALSE, size = FALSE)
here is the two resulting graphs
My goal is to make a third graph with hexbins with the values of the difference between hexbins at the same coordinates but I don't even know how to start to do it, I have done something similar in the raster Package, but I need it as hexbins
Thanks a lot
You need to make sure that both plots use the exact same binning. In order to achieve this, I think it is best to do the binning beforehand and then plot the results with stat_identity / geom_hex. With the variables from your code sample you ca do:
## find the bounds for the complete data
xbnds <- range(c(A$x, B$x))
ybnds <- range(c(A$y, B$y))
nbins <- 30
# function to make a data.frame for geom_hex that can be used with stat_identity
makeHexData <- function(df) {
h <- hexbin(df$x, df$y, nbins, xbnds = xbnds, ybnds = ybnds, IDs = TRUE)
data.frame(hcell2xy(h),
z = tapply(df$z, h#cID, FUN = function(z) sum(z)/length(z)),
cid = h#cell)
}
Ahex <- makeHexData(A)
Bhex <- makeHexData(B)
## not all cells are present in each binning, we need to merge by cellID
byCell <- merge(Ahex, Bhex, by = "cid", all = T)
## when calculating the difference empty cells should count as 0
byCell$z.x[is.na(byCell$z.x)] <- 0
byCell$z.y[is.na(byCell$z.y)] <- 0
## make a "difference" data.frame
Diff <- data.frame(x = ifelse(is.na(byCell$x.x), byCell$x.y, byCell$x.x),
y = ifelse(is.na(byCell$y.x), byCell$y.y, byCell$y.x),
z = byCell$z.x - byCell$z.y)
## plot the results
ggplot(Ahex) +
geom_hex(aes(x = x, y = y, fill = z),
stat = "identity", alpha = 0.8) +
scale_fill_gradientn (colours = c("blue","red")) +
guides(alpha = FALSE, size = FALSE)
ggplot(Bhex) +
geom_hex(aes(x = x, y = y, fill = z),
stat = "identity", alpha = 0.8) +
scale_fill_gradientn (colours = c("blue","red")) +
guides(alpha = FALSE, size = FALSE)
ggplot(Diff) +
geom_hex(aes(x = x, y = y, fill = z),
stat = "identity", alpha = 0.8) +
scale_fill_gradientn (colours = c("blue","red")) +
guides(alpha = FALSE, size = FALSE)
I used alphahull package to delineate dots on a map.
I plot the contours with a geom_segment.
My question is : how to fill the delineation given by the segment with a color ?
Here is a reproducible example :
set.seed(2)
dat <- data.frame(x = rnorm(20, 10, 5), y = rnorm(20, 20, 5), z = c(rep(1, 6), rep(2, 4)))
library(ggplot2)
library(alphahull)
alpha <- 100
alphashape1 <- ashape(dat[which(dat$z==1), c("x", "y")], alpha = alpha)
alphashape2 <- ashape(dat[which(dat$z==2), c("x", "y")], alpha = alpha)
map <- ggplot(dat, aes(x = x, y = y)) +
geom_point(data = dat, aes(x = x, y = y, colour = as.factor(dat$z))) +
geom_segment(data = data.frame(alphashape1$edges), aes(x = x1, y = y1, xend = x2, yend = y2, colour = levels(as.factor(dat$z))[1])) +
geom_segment(data = data.frame(alphashape2$edges), aes(x = x1, y = y1, xend = x2, yend = y2, colour = levels(as.factor(dat$z))[2]))
map
I believe this works w/o the need for graph ops:
fortify.ashape <- function(ashape_res) {
xdf <- data.frame(ashape_res$edges)
xdf <- do.call(
rbind,
lapply(1:nrow(xdf), function(i) {
rbind(
data.frame(x=xdf$x1[i], y=xdf$y1[i]),
data.frame(x=xdf$x2[i], y=xdf$y2[i])
)
})
)
xdf <- xdf[order(-1 * atan2(
xdf$y - mean(range(xdf$y)),
xdf$x - mean(range(xdf$x)))), c("x", "y")]
xdf <- rbind.data.frame(xdf[nrow(xdf),], xdf[1:(nrow(xdf)-1),])
xdf
}
alphashape1 <- ashape(dat[which(dat$z == 1), c("x", "y")], alpha = 15)
alphashape2 <- ashape(dat[which(dat$z == 2), c("x", "y")], alpha = 15)
ggplot() +
geom_point(data = dat, aes(x = x, y = y, colour = as.factor(dat$z))) +
geom_polygon(data=alphashape1, aes(x, y), fill="red", alpha=2/3) +
geom_polygon(data=alphashape2, aes(x, y), fill="blue", alpha=2/3)
This is because the ashape function only returns segments, not in any order.
The only way I found to reconstruct the order was by using the node information to form a graph and then find the shortest path along that graph.
A detailed example is here: https://rpubs.com/geospacedman/alphasimple - the code needs wrapping into a single function, which should be fairly easy to do. Once you have that order sorted, geom_polygon will draw it with filled shading in ggplot2.
Based on Spacedman's answer, I ordered separately the two sets of points and came up with this solution.
It could be optimized with a function that does it for each group automatically.
set.seed(2)
dat <- data.frame(x = rnorm(20, 10, 5), y = rnorm(20, 20, 5), z = c(rep(1, 6), rep(2, 4)))
library(ggplot2)
library(alphahull)
alpha <- 100
alphashape1 <- ashape(dat[which(dat$z==1), c("x", "y")], alpha = alpha)
alphashape2 <- ashape(dat[which(dat$z==2), c("x", "y")], alpha = alpha)
map <- ggplot(dat, aes(x = x, y = y)) +
geom_point(data = dat, aes(x = x, y = y, colour = as.factor(dat$z))) +
geom_segment(data = data.frame(alphashape1$edges), aes(x = x1, y = y1, xend = x2, yend = y2, colour = levels(as.factor(dat$z))[1])) +
geom_segment(data = data.frame(alphashape2$edges), aes(x = x1, y = y1, xend = x2, yend = y2, colour = levels(as.factor(dat$z))[2]))
map
alpha <- 15 # transparency argument
# First contour
alphashape1 <- ashape(dat[which(dat$z == 1), c("x", "y")], alpha = alpha)
alphashape1_ind <- alphashape1$edges[, c("ind1", "ind2")]
class(alphashape1_ind) = "character"
alphashape1_graph <- graph.edgelist(alphashape1_ind, directed = FALSE)
cut_graph1 <- alphashape1_graph - E(alphashape1_graph)[1] # Cut the first edge
ends1 <- names(which(degree(cut_graph1) == 1)) # Get two nodes with degree = 1
path1 <- get.shortest.paths(cut_graph1, ends1[1], ends1[2])$vpath[[1]]
path_nodes1 <- as.numeric(V(alphashape1_graph)[path1]$name)
# Second contour
alphashape2 <- ashape(dat[which(dat$z == 2), c("x", "y")], alpha = alpha)
alphashape2_ind <- alphashape2$edges[, c("ind1", "ind2")]
class(alphashape2_ind) = "character"
alphashape2_graph <- graph.edgelist(alphashape2_ind, directed = FALSE)
cut_graph2 <- alphashape2_graph - E(alphashape2_graph)[1] # Cut the first edge
ends2 <- names(which(degree(cut_graph2) == 1)) # Get two nodes with degree = 1
path2 <- get.shortest.paths(cut_graph2, ends2[1], ends2[2])$vpath[[1]]
path_nodes2 <- as.numeric(V(alphashape2_graph)[path2]$name)
# Updating of previous plot (see question)
map +
geom_polygon(data = dat[which(dat$z == 1), c("x", "y")][path_nodes1, ], aes(x = x, y = y),
fill = "red", colour = "red", size = 0.5, alpha = 0.3) +
geom_polygon(data = dat[which(dat$z == 2), c("x", "y")][path_nodes2, ],
aes(x = x, y = y), colour = "blue", fill = "blue", size = 0.5, alpha = 0.3)
Let's generate some data:
x <- -10*cos(seq(0, pi, length.out = 100))+1
y <- 10*seq(0, pi, length.out = 100)
xerr <- rep(2, 100)
yerr <- rep(2, 100)
dd <- as.data.frame(cbind(x, y, xerr, yerr))
Here I have x and y coordinates of some points with their errors, xerr and yerr (for convenience I have set them constant). I would like to represent these errors with the size of the points. This is easily doable:
ggplot() +
geom_point(data = dd, aes(x, y, size = sqrt(xerr^2 + yerr^2)), colour = "gray") +
geom_path(data = dd, aes(x, y), colour = "red", size = .5) +
scale_size_identity() +
theme_bw()
However, the size of these points is defined on a scale that doesn't have any relation with the scale of the plot. Is there a way to adjust the dimension of the points in relation to the scale of the plot? In the above example, the radius of each point should have size equal to 2.828 and not less than one as it is now.
One way is to explicitly draw ellipses with the axes defined by the size of the errors.
x <- -10*cos(seq(0, pi, length.out = 10))+1
y <- 10*seq(0, pi, length.out = 10)
xerr <- runif(10, 1, 5)
yerr <- runif(10, 1, 5)
dd <- as.data.frame(cbind(x, y, xerr, yerr))
dd$frame <- factor(seq(1:10))
For this purpose we define our function to generate ellipses:
ellipseFun <- function(center = c(0, 0), axes = c(1, 1), npoints = 101){
tt <- seq(0,2*pi, length.out = npoints)
xx <- center[1] + axes[1] * cos(tt)
yy <- center[2] + axes[2] * sin(tt)
return(data.frame(x = xx, y = yy))
}
We then generate the matrices for all ellipses:
ddEll <- data.frame()
for(k in levels(dd$frame)){
ddEll <- rbind(ddEll, cbind(as.data.frame(with(dd[dd$frame == k,], ellipseFun(center = c(x, y), axes = c(xerr, yerr), npoints = 101))),frame = k))
}
And, finally, we can plot them:
library(ggplot2)
ggplot() +
geom_point(data = dd, aes(x, y)) +
geom_polygon(data=ddEll, aes(x = x, y = y, group = frame), colour = "gray", fill = "red", alpha = .2) +
scale_size_identity() +
theme_bw() +
xlim(c(-20, 20)) +
ylim(c(-5, 35)) +
coord_fixed()