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
Related
library(ggplot2)
dev.new()
set.seed(1684)
x = seq(15, 33, by = 0.9)
f <- function(x) {
out <- ifelse(
x < 15 | 33 < x,
0,
ifelse(
15 <= x & x <= 24,
(2*(x-15))/((33-15)*(24-15)),
ifelse(
24 < x & x <= 33,
(2*(33-x))/((33-15)*(33-24)),
NA_real_
)))
if (any((is.na(out) | is.nan(out)) & (!is.na(x) & !is.nan(x)))) {
warning("f(x) undefined for some input values")
}
out
}
x_accept <- numeric(0)
while (length(x_accept) != 105) {
x1 = runif(1, min = 15, max = 33)
num = runif(1, min = 0, max = 1)
if (num < (f(x1)/2/(33-15))) {
x_accept = c(x_accept, x1)
}
}
histo <- data.frame(x = x_accept)
dat <- data.frame(x = x, y = f(x), z = histo)
ggplot(dat) +
geom_line(aes(x, y), color = "red") +
geom_histogram(aes(histo), alpha = .5, binwidth = 1)
When I use this code it gives me the error, I think it assumes that 'histo' is a list, but it's a dataframe, so I don't really know what's wrong.
use data=histo and set x=x and y to density (y=..density..)
ggplot(dat) +
geom_line(aes(x, y), color = "red") +
geom_histogram(aes(x,..density..),data=histo, alpha = .5, binwidth = 1)
or using only one dataframe:
dat <- data.frame(x = x, y = f(x), z = x_accept) #z=x_accept instead of histo
ggplot(dat) +
geom_line(aes(x, y), color = "red") +
geom_histogram(aes(z,..density..), alpha = .5, binwidth = 1)
I've been asked to remove points from a plot that I've made with ggplot2. I'm attaching a MWE:
require(ggplot2)
require(Hmisc)
x = 5
k = 50
kx = k*5
data.A.1 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 0)
data.B.1 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 1)
data.C.1 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 2)
data.A.2 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 3)
data.B.2 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 4)
data.C.2 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 5)
multiple.plot.6x3.interval <- function(D, L) {
data = data.frame()
# join all the data in D into 'data'
e = 0
NN = ""
for (i in seq(1, length(D))) {
lidx = i%%3
if (lidx == 0) { lidx = 3 }
if (lidx == 1) {
e = e + 1
NN = paste0("10^", e)
}
n.obs = length(D[[i]]$n)
D[[i]]$lang.name = rep(L[lidx], n.obs)
D[[i]]$N = rep(NN, n.obs)
data = rbind(data, D[[i]])
}
# make the plot
g <- ggplot(data, aes(x=n, y=v)) +
stat_summary( # plot confidence interval
fun.data = mean_cl_boot, fun.args = (conf.int = 0.99),
geom = "ribbon", fill = "darkgrey"
) +
stat_summary( # plot maximum and minimum bars
fun = mean, fun.min = min, fun.max = max,
colour = "red", size = 0.15
) +
stat_summary(
fun = mean,
geom = "line", linetype = "solid", size = 0.4, color = "black"
) +
coord_cartesian(xlim=c(1, 100)) +
scale_x_continuous(breaks=seq(1, 101, 10)-1) +
facet_grid(
N ~ lang.name, labeller = "label_parsed"
) +
labs(
x=bquote("X"),
y=bquote("Y")
) +
theme(text = element_text(size = 20))
return (g)
}
g <- multiple.plot.6x3.interval(
list(
data.A.1, data.B.1, data.C.1,
data.A.2, data.B.2, data.C.2
),
c("A", "B", "C")
)
plot(g)
The result of this code is the one I want, but with the exception that I've been asked to remove the points that this
stat_summary( # plot maximum and minimum bars
fun = mean, fun.min = min, fun.max = max,
colour = "red", size = 0.15
) +
generates while keeping the bars.
This is what I get, and I would like to remove the red points (not the red bars).
Using size = 0 will make the bars completely invisible. I haven't been able to do this myself. I wonder: can this be done? If so, how? Any help will be appreciated.
Thank you all.
Try geom = "errorbar" as an argument to stat_summary:
require(ggplot2)
require(Hmisc)
x = 5
k = 50
kx = k*5
data.A.1 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 0)
data.B.1 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 1)
data.C.1 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 2)
data.A.2 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 3)
data.B.2 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 4)
data.C.2 = data.frame(n = rep(sample(1:100, k, replace=FALSE), x), v = rnorm(kx, 1, 2) + 5)
multiple.plot.6x3.interval <- function(D, L) {
data = data.frame()
# join all the data in D into 'data'
e = 0
NN = ""
for (i in seq(1, length(D))) {
lidx = i%%3
if (lidx == 0) { lidx = 3 }
if (lidx == 1) {
e = e + 1
NN = paste0("10^", e)
}
n.obs = length(D[[i]]$n)
D[[i]]$lang.name = rep(L[lidx], n.obs)
D[[i]]$N = rep(NN, n.obs)
data = rbind(data, D[[i]])
}
# make the plot
g <- ggplot(data, aes(x=n, y=v)) +
stat_summary( # plot confidence interval
fun.data = mean_cl_boot, fun.args = (conf.int = 0.99),
geom = "ribbon", fill = "darkgrey"
) +
stat_summary( # plot maximum and minimum bars
fun = mean, fun.min = min, fun.max = max,
geom = "errorbar", ### HERE
colour = "red", size = 0.15
) +
stat_summary(
fun = mean,
geom = "line", linetype = "solid", size = 0.4, color = "black"
) +
coord_cartesian(xlim=c(1, 100)) +
scale_x_continuous(breaks=seq(1, 101, 10)-1) +
facet_grid(
N ~ lang.name, labeller = "label_parsed"
) +
labs(
x=bquote("X"),
y=bquote("Y")
) +
theme(text = element_text(size = 20))
return (g)
}
g <- multiple.plot.6x3.interval(
list(
data.A.1, data.B.1, data.C.1,
data.A.2, data.B.2, data.C.2
),
c("A", "B", "C")
)
plot(g)
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')
I am trying to replicate the following picture in R, in particular with ggplot2
I was able to draw the red rss contour lines but I've no idea how to draw a diamond (like the one in the left picture). The "expected Output" should be a way to draw a diamond with a given side length.
EDIT: Here is a short reproducible example to add the diamond randomly inside the following plot:
mlb<- read.table('https://umich.instructure.com/files/330381/download?download_frd=1', as.is=T, header=T)
str(mlb)
fit<-lm(Height~Weight+Age-1, data = as.data.frame(scale(mlb[,4:6])))
points = data.frame(x=c(0,fit$coefficients[1]),y=c(0,fit$coefficients[2]),z=c("(0,0)","OLS Coef"))
Y=scale(mlb$Height)
X = scale(mlb[,c(5,6)])
beta1=seq(-0.556, 1.556, length.out = 100)
beta2=seq(-0.661, 0.3386, length.out = 100)
df <- expand.grid(beta1 = beta1, beta2 = beta2)
b = as.matrix(df)
df$sse <- rep(t(Y)%*%Y,100*100) - 2*b%*%t(X)%*%Y + diag(b%*%t(X)%*%X%*%t(b))
base <- ggplot() +
stat_contour(data=df, aes(beta1, beta2, z = sse),breaks = round(quantile(df$sse, seq(0, 0.2, 0.03)), 0),
size = 0.5,color="darkorchid2",alpha=0.8) +
scale_x_continuous(limits = c(-0.4,1))+
scale_y_continuous(limits = c(-0.55,0.4))+
geom_point(data = points,aes(x,y))+
geom_text(data = points,aes(x,y,label=z),vjust = 2,size=3.5)
base
You can draw shapes with geom_polygon.
library(ggplot2)
df <- data.frame(x = c(1, 0, -1, 0), y = c(0, 1, 0, -1))
ggplot(df) + geom_polygon(aes(x = x, y = y))
If you want to generate the coordinates from a center and a side length, you can transform a base matrix. You can also combine this with an existing plot by supplying the coordinates to the data argument of the geom instead of to ggplot() as shown. Change the sqrt2 scaling if you want the corner-to-center as the argument instead of the side length.
diamond <- function(side_length, center) {
base <- matrix(c(1, 0, 0, 1, -1, 0, 0, -1), nrow = 2) * sqrt(2) / 2
trans <- (base * side_length) + center
as.data.frame(t(trans))
}
ggplot() + geom_polygon(data = diamond(2, c(1, 2)), mapping = aes(x = V1, y = V2))
Here's an example of adding it in to your provided data. Note that I put it before (underneath) the text, and named the arguments to be clear (probably the source of that object coercible by fortify error.
mlb <- read.table("https://umich.instructure.com/files/330381/download?download_frd=1", as.is = T, header = T)
fit <- lm(Height ~ Weight + Age - 1, data = as.data.frame(scale(mlb[, 4:6])))
points <- data.frame(x = c(0, fit$coefficients[1]), y = c(0, fit$coefficients[2]), z = c("(0,0)", "OLS Coef"))
Y <- scale(mlb$Height)
X <- scale(mlb[, c(5, 6)])
beta1 <- seq(-0.556, 1.556, length.out = 100)
beta2 <- seq(-0.661, 0.3386, length.out = 100)
df <- expand.grid(beta1 = beta1, beta2 = beta2)
b <- as.matrix(df)
df$sse <- rep(t(Y) %*% Y, 100 * 100) - 2 * b %*% t(X) %*% Y + diag(b %*% t(X) %*% X %*% t(b))
ggplot(df) +
stat_contour(aes(beta1, beta2, z = sse),
breaks = round(quantile(df$sse, seq(0, 0.2, 0.03)), 0),
size = 0.5, color = "darkorchid2", alpha = 0.8
) +
geom_polygon(data = diamond(0.1, c(0, 0)), mapping = aes(x = V1, y = V2), fill = "cadetblue1") +
scale_x_continuous(limits = c(-0.4, 1)) +
scale_y_continuous(limits = c(-0.55, 0.4)) +
geom_point(data = points, aes(x, y)) +
geom_text(data = points, aes(x, y, label = z), vjust = 2, size = 3.5)
#> Warning: Removed 4215 rows containing non-finite values (stat_contour).
Created on 2018-08-01 by the reprex package (v0.2.0).
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()