Add a gradient of intensiy to an interference plot - r

I want to plot the gradient plot of intensities, something like this:
I though myself about creating a gradient grid whose distribution was my "I" function, but I have no idea how to do it or if there is an explicit package in R to accomplish this task.
Thank you so much for even thinking about this.
a <- 5*10^(-6)
d <- 0.5*0.005
l <- 500*10^(-9)
n <- pi
theta <- seq(-n,n,length=3500)
I <- function(x){(cos((pi*d*sin(x))/l))^2*(sin((pi*a*sin(x))/l)/((pi*a*sin(x))/l))^2}
y1 <- lapply(theta,I)
y <- unlist(y1)
df <- data.frame(theta,y)
I2 <- function(x){(sin((pi*a*sin(x))/l)/((pi*a*sin(x))/l))^2}
y12 <- lapply(theta,I2)
y2 <- unlist(y12)
df2 <- data.frame(theta,y2)
p = ggplot()
p +
geom_line(data = df, aes(theta,y)) +
xlim(-0.3,0.3) +
geom_line(data = df2, aes(theta,y2))

Making use of patchwork this could be achieved like so:
For the gradient make a second ggplot of rectangles using e.g. geom_rect where you map intensity on color and/or fill
This gradient plot could then be glued to the main plot via patchwork
To get a nice gradient plot
I tripled the number of grid points for the gradient plot,
mapped the cubic root of intensity on color and
get rid of all unnecessary elemnts like y-axis, color guide, ...
BTW:
As your functions are vectorized you don't need lapply to compute the intensities.
Instead of adjusting the limits via xlim() (which removes rows falling outside of the range), set them using coord_cartesian.
library(ggplot2)
library(tibble)
library(patchwork)
a <- 5*10^(-6)
d <- 0.5*0.005
l <- 500*10^(-9)
n <- pi
theta <- seq(-n,n,length=3500)
I <- function(x){(cos((pi*d*sin(x))/l))^2*(sin((pi*a*sin(x))/l)/((pi*a*sin(x))/l))^2}
y <- I(theta)
df <- data.frame(theta,y)
I2 <- function(x){(sin((pi*a*sin(x))/l)/((pi*a*sin(x))/l))^2}
y2 <- I2(theta)
df2 <- data.frame(theta,y2)
p1 = ggplot() +
geom_line(data = df, aes(theta,y)) +
geom_line(data = df2, aes(theta,y2)) +
coord_cartesian(xlim = c(-0.3,0.3))
g <- tibble(
xmin = seq(-n, n, length = 3 * 3500),
xmax = dplyr::lead(xmin),
y = I(xmin)
)
p2 <- ggplot(g, aes(xmin = xmin, xmax = xmax, ymin = 0, ymax = 1, color = y^(1/3))) +
geom_rect() +
coord_cartesian(xlim = c(-0.3,0.3)) +
guides(color = FALSE) +
theme_minimal() +
theme(axis.ticks.y = element_blank(), axis.text.y = element_blank())
p1 / p2 + plot_layout(heights = c(10, 1))
#> Warning: Removed 1 rows containing missing values (geom_rect).

Related

How to overlay two heatmaps via ggplot2 with two different scales_fill_gradient?

I have a data which has two variables and I want to see a single plot with heatmap for each of them overlaid on one another and showing two color scales for the two different variables. My code while not correct should clearly indicate what I am trying to achieve.
I have looked through several examples none of those indicate how to do this for geom_tile(). It would have been easy for geom_point. I am providing a synthetic example to show what I am doing. I get the error saying "Scale for 'fill' is already present. Adding another scale for 'fill', which will replace the existing scale." Evidently it is accepting only the second scale_fill_gradient, but I would like to view both the color gradients corresponding to the variables in the same heatmap.
It would be great if I could find a way to get this plot. Thank you!
library(reshape2)
library(ggplot2)
set.seed(2)
m1 = matrix(rnorm(100), nrow=10)
m2 = matrix(rnorm(100), nrow=10)
M1 = melt(m1)
M2 = melt(m2)
names(M1) = c("Var1", "Var2", "value1")
names(M2) = c("Var1", "Var2", "value2")
pp1 <- ggplot() +
geom_tile(data=M1, aes(x=Var1, y=Var2, fill=value1)) +
scale_fill_gradient(low="white", high="red") +
geom_tile(data=M2, aes(x=Var1, y=Var2, fill=value2)) +
scale_fill_gradient(low="blue", high="yellow")
pp1
So the legends themselves are no problem with the ggnewscale package, the problem lies in choosing the actual colours that you want to display. So let's make a new matrix with the actual colours you want to display:
library(ggnewscale)
library(scales)
r <- rescale(M1$value1)
# 1 - rescaled value because yellow should be bottom
g <- 1 - rescale(M2$value2)
# Second scale goes from yellow (low) to blue (high)
# Yellow is 100% blue, 100% green, so blue stays invariant
rgb <- rgb(r, g, 1)
# Make new matrix
M3 <- M1
M3$value1 <- rgb
And now plotting would occur as follows:
ggplot(mapping = aes(x = Var1, y = Var2)) +
# This bit is for making scales
geom_tile(data=M1, aes(fill = value1)) +
scale_fill_gradient(low = "white", high = "red") +
new_scale_fill() +
geom_tile(data=M2, aes(fill=value2)) +
scale_fill_gradient(low="yellow", high="blue") +
new_scale_fill() +
# This is the actual colours
geom_tile(data=M3, aes(fill = M3$value1)) +
scale_fill_identity()
The legends aren't 100% accurate since ggplot mixes colours in 'Lab' space, while we've mixed colours in rgb space, but you could replace the scale_fill_gradient() with for example scale_fill_gradientn(colours = rgb(seq(0, 1, length.out = 100), 0, 0)). Also be aware that the white-to-red scale should technically be a black-to-red scale in this example.
A bivariate color legend. The intervals should maybe be the corresponding quantile.
library(tidyverse)
library(cowplot)
set.seed(2)
m1 = matrix(rnorm(100), nrow=10)
m2 = matrix(rnorm(100), nrow=10)
M1 = melt(m1)
M2 = melt(m2)
names(M1) = c("Var1", "Var2", "value1")
names(M2) = c("Var1", "Var2", "value2")
M1$value_cut <- cut(M1$value1, breaks = 3)
M2$value_cut <- cut(M2$value2, breaks = 3)
M1$value_cut2 <- M2$value_cut
M1$cuts <- paste(M1$value_cut, M1$value_cut2, sep = "-")
levels_comb <- expand.grid(lev1 = levels(M1$value_cut), lev2 = levels(M2$value_cut))
levels_comb$cuts <- paste(levels_comb$lev1, levels_comb$lev2, sep = "-")
levels_comb$filling <- c("#be64ac","#8c62aa","#3b4994","#dfb0d6","#a5add3","#5698b9","#e8e8e8","#ace4e4","#5ac8c8")
data_m <- left_join(M1, levels_comb, by = "cuts")
plot_tile <- ggplot(data_m, aes(x = Var1, y = Var2, fill = filling)) +
geom_tile() +
scale_fill_identity() +
coord_equal() +
theme_minimal()
legend_tile <- ggplot(levels_comb, aes(x = lev1, y = lev2, fill = filling)) +
geom_tile() +
scale_fill_identity() +
coord_equal() +
theme_minimal() +
theme(axis.text.x = element_text(angle = 45, hjust = 1))
ggdraw() +
draw_plot(plot_tile, 0, 0, 1, 1) +
draw_plot(legend_tile, .75, .4, .3, .3)
I find geom_col() + facet_grid() to be a useful pattern to get at your goal of visualizing the multiple values from the same area together.
There is a little set-up overhead from your starting data:
names(M1) = c("Var1", "Var2", "value")
names(M2) = c("Var1", "Var2", "value")
M1$type <- "M1"
M2$type <- "M2"
M <- rbind(M1, M2)
But the plot is straight forward. You don't really need the fill scale anymore, but I like to keep for highlighting the value changes.
ggplot(M) +
geom_col(aes(type, value, fill = value)) +
facet_grid(Var2 ~ Var1) +
scale_fill_gradient(low="blue", high="yellow")
Not sure if this is palatable for you or not, but at least you get to see an alternative viz option.

R geom_ribbon not shading area under density curve properly over interval

I am trying to shade the area under a lognormal density plot for a certain interval using the code below. This has worked for me in the past using other density functions and intervals, but for some reason now it produces the defect you can see in the graphic.
library(ggplot2)
library(plyr)
library(dplyr)
library(tidyr)
x <- seq(0, 43, 0.1)
x_min <- 16
x_max <- 22
df <- data.frame(x = x, f = dlnorm(x, meanlog = 2.5,
sdlog = 0.24))
df <- df %>% mutate(area = ifelse(x >= x_min & x < x_max,
"Participating", "Not Participating"))
gg <- ggplot(data = df, aes(x = x, ymin = 0, ymax = f, fill = area))
gg <- gg + geom_ribbon()
gg <- gg + theme(legend.title = element_blank())
gg
The issue here is that you are trying to have a ribbon consisting of two pieces. Consequently, the two intended red areas try to connect to each other: ymax where the left area ends and ymax where the right one starts, and the same for ymin. Probably in the past you always used this method for the distribution tails and this problem never arose.
As to solve this, you are going to need to somehow manually have two geom_ribbon. A not particularly intrusive way would be
gg <- ggplot(data = df, aes(x = x, ymin = 0, ymax = f))
gg <- gg + geom_ribbon(aes(fill = factor("Not participating")))
gg <- gg + geom_ribbon(data = df[df$area == "Participating", ], aes(fill = area))
gg <- gg + theme(legend.title = element_blank())
Depending on that you wish to do with colors, it potentially can be further modified/simplified.

Create a colour blind test with ggplot

I would like to create a colour blind test, similar to that below, using ggplot.
The basic idea is to use geom_hex (or perhaps a voronoi diagram, or possibly even circles as in the figure above) as the starting point, and define a dataframe that, when plotted in ggplot, produces the image.
We would start by creating a dataset, such as:
df <- data.frame(x = rnorm(10000), y = rnorm(10000))
then plot this:
ggplot(df, aes(x, y)) +
geom_hex() +
coord_equal() +
scale_fill_gradient(low = "red", high = "green", guide = FALSE) +
theme_void()
which gives the image below:
The main missing step is to create a dataset that actually plots a meaningful symbol (letter or number), and I'm not sure how best to go about this without painstakingly mapping the coordinates. Ideally one would be able to read in the coordinates perhaps from an image file.
Finally, a bit of tidying up could round the plot edges by removing the outlying points.
All suggestions are very welcome!
EDIT
Getting a little closer to what I'm after, we can use the image below of the letter 'e':
Using the imager package, we can read this in and convert it to a dataframe:
img <- imager::load.image("e.png")
df <- as.data.frame(img)
then plot that dataframe using geom_raster:
ggplot(df, aes(x, y)) +
geom_raster(aes(fill = value)) +
coord_equal() +
scale_y_continuous(trans = scales::reverse_trans()) +
scale_fill_gradient(low = "red", high = "green", guide = FALSE) +
theme_void()
If we use geom_hex instead of geom_raster, we can get the following plot:
ggplot(df %>% filter(value %in% 1), aes(x, y)) +
geom_hex() +
coord_equal() +
scale_y_continuous(trans = scales::reverse_trans()) +
scale_fill_gradient(low = "red", high = "green", guide = FALSE) +
theme_void()
so, getting there but clearly still a long way off...
Here's an approach for creating this plot:
Packages you need:
library(tidyverse)
library(packcircles)
Get image into a 2D matrix (x and y coordinates) of values. To do this, I downloaded the .png file of the e as "e.png" and saved in my working directory. Then some processing:
img <- png::readPNG("e.png")
# From http://stackoverflow.com/questions/16496210/rotate-a-matrix-in-r
rotate <- function(x) t(apply(x, 2, rev))
# Convert to one colour layer and rotate it to be in right direction
img <- rotate(img[,,1])
# Check that matrix makes sense:
image(img)
Next, create a whole lot of circles! I did this based on this post.
# Create random "circles"
# *** THESE VALUES WAY NEED ADJUSTING
ncircles <- 1200
offset <- 100
rmax <- 80
x_limits <- c(-offset, ncol(img) + offset)
y_limits <- c(-offset, nrow(img) + offset)
xyr <- data.frame(
x = runif(ncircles, min(x_limits), max(x_limits)),
y = runif(ncircles, min(y_limits), max(y_limits)),
r = rbeta(ncircles, 1, 10) * rmax)
# Find non-overlapping arrangement
res <- circleLayout(xyr, x_limits, y_limits, maxiter = 1000)
cat(res$niter, "iterations performed")
#> 1000 iterations performed
# Convert to data for plotting (just circles for now)
plot_d <- circlePlotData(res$layout)
# Check circle arrangement
ggplot(plot_d) +
geom_polygon(aes(x, y, group=id), colour = "white", fill = "skyblue") +
coord_fixed() +
theme_minimal()
Finally, interpolate the image pixel values for the centre of each circle. This will indicate whether a circle is centered over the shape or not. Add some noise to get variance in colour and plot.
# Get x,y positions of centre of each circle
circle_positions <- plot_d %>%
group_by(id) %>%
summarise(x = min(x) + (diff(range(x)) / 2),
y = min(y) + (diff(range(y)) / 2))
# Interpolate on original image to get z value for each circle
circle_positions <- circle_positions %>%
mutate(
z = fields::interp.surface(
list(x = seq(nrow(img)), y = seq(ncol(img)), z = img),
as.matrix(.[, c("x", "y")])),
z = ifelse(is.na(z), 1, round(z)) # 1 is the "empty" area shown earlier
)
# Add a little noise to the z values
set.seed(070516)
circle_positions <- circle_positions %>%
mutate(z = z + rnorm(n(), sd = .1))
# Bind z value to data for plotting and use as fill
plot_d %>%
left_join(select(circle_positions, id, z)) %>%
ggplot(aes(x, y, group = id, fill = z)) +
geom_polygon(colour = "white", show.legend = FALSE) +
scale_fill_gradient(low = "#008000", high = "#ff4040") +
coord_fixed() +
theme_void()
#> Joining, by = "id"
To get colours right, tweak them in scale_fill_gradient

Add a legend for geom_polygon

I'm trying to produce a scatter plot with geom_point where the points are circumscribed by a smoothed polygon, with geom_polygon.
Here's my point data:
set.seed(1)
df <- data.frame(x=c(rnorm(30,-0.1,0.1),rnorm(30,0,0.1),rnorm(30,0.1,0.1)),y=c(rnorm(30,-1,0.1),rnorm(30,0,0.1),rnorm(30,1,0.1)),val=rnorm(90),cluster=c(rep(1,30),rep(2,30),rep(3,30)),stringsAsFactors=F)
I color each point according the an interval that df$val is in. Here's the interval data:
intervals.df <- data.frame(interval=c("(-3,-2]","(-2,-0.999]","(-0.999,0]","(0,1.96]","(1.96,3.91]","(3.91,5.87]","not expressed"),
start=c(-3,-2,-0.999,0,1.96,3.91,NA),end=c(-2,-0.999,0,1.96,3.91,5.87,NA),
col=c("#2f3b61","#436CE8","#E0E0FF","#7d4343","#C74747","#EBCCD6","#D3D3D3"),stringsAsFactors=F)
Assigning colors and intervals to the points:
df <- cbind(df,do.call(rbind,lapply(df$val,function(x){
if(is.na(x)){
return(data.frame(col=intervals.df$col[nrow(intervals.df)],interval=intervals.df$interval[nrow(intervals.df)],stringsAsFactors=F))
} else{
idx <- which(intervals.df$start <= x & intervals.df$end >= x)
return(data.frame(col=intervals.df$col[idx],interval=intervals.df$interval[idx],stringsAsFactors=F))
}
})))
Preparing the colors for the leged which will show each interval:
df$interval <- factor(df$interval,levels=intervals.df$interval)
colors <- intervals.df$col
names(colors) <- intervals.df$interval
Here's where I constructed the smoothed polygons (using a function courtesy of this link):
clusters <- sort(unique(df$cluster))
cluster.cols <- c("#ff00ff","#088163","#ccbfa5")
splinePolygon <- function(xy,vertices,k=3, ...)
{
# Assert: xy is an n by 2 matrix with n >= k.
# Wrap k vertices around each end.
n <- dim(xy)[1]
if (k >= 1) {
data <- rbind(xy[(n-k+1):n,], xy, xy[1:k, ])
} else {
data <- xy
}
# Spline the x and y coordinates.
data.spline <- spline(1:(n+2*k), data[,1], n=vertices, ...)
x <- data.spline$x
x1 <- data.spline$y
x2 <- spline(1:(n+2*k), data[,2], n=vertices, ...)$y
# Retain only the middle part.
cbind(x1, x2)[k < x & x <= n+k, ]
}
library(data.table)
hulls.df <- do.call(rbind,lapply(1:length(clusters),function(l){
dt <- data.table(df[which(df$cluster==clusters[l]),])
hull <- dt[, .SD[chull(x,y)]]
spline.hull <- splinePolygon(cbind(hull$x,hull$y),100)
return(data.frame(x=spline.hull[,1],y=spline.hull[,2],val=NA,cluster=clusters[l],col=cluster.cols[l],interval=NA,stringsAsFactors=F))
}))
hulls.df$cluster <- factor(hulls.df$cluster,levels=clusters)
And here's my ggplot command:
library(ggplot2)
p <- ggplot(df,aes(x=x,y=y,colour=interval))+geom_point(cex=2,shape=1,stroke=1)+labs(x="X", y="Y")+theme_bw()+theme(legend.key=element_blank(),panel.border=element_blank(),strip.background=element_blank())+scale_color_manual(drop=FALSE,values=colors,name="DE")
p <- p+geom_polygon(data=hulls.df,aes(x=x,y=y,group=cluster),color=hulls.df$col,fill=NA)
which produces:
My question is how do I add a legend for the polygon under the legend for the points? I want it to a legend with 3 lines colored according to the cluster colors and the corresponding cluster number beside each line?
Slightly different output, only changing the last line of your code, it may solve your purpose:
p+geom_polygon(data=hulls.df,aes(x=x,y=y,group=cluster, fill=cluster),alpha=0.1)
Say, you want to add a legend of the_factor. My basic idea is,
(1) put the_factor into mapping by using unused aes arguments; aes(xx = the_factor)
(2) if (1) affects something, delete the effect by using scale_xx_manual()
(3) modify the legend by using guides(xx = guide_legend(override.aes = list()))
In your case, aes(fill) and aes(alpha) are unused. The former is better to do it because of no effect. So I used aes(fill=as.factor(cluster)).
p <- ggplot(df,aes(x=x,y=y,colour=interval, fill=as.factor(cluster))) + # add aes(fill=...)
geom_point(cex=2, shape=1, stroke=1) +
labs(x="X", y="Y",fill="cluster") + # add fill="cluster"
theme_bw() + theme(legend.key=element_blank(),panel.border=element_blank(),strip.background=element_blank()) + scale_color_manual(drop=FALSE,values=colors,name="DE") +
guides(fill = guide_legend(override.aes = list(colour = cluster.cols, pch=0))) # add
p <- p+geom_polygon(data=hulls.df,aes(x=x,y=y,group=cluster), color=hulls.df$col,fill=NA)
Of course, you can make the same graph by using aes(alpha = the_factor)). Because it has influence, you need to control it by using scale_alpha_manual().
g <- ggplot(df, aes(x=x,y=y,colour=interval)) +
geom_point(cex=2, shape=1, stroke=1, aes(alpha=as.factor(cluster))) + # add aes(alpha)
labs(x="X", y="Y",alpha="cluster") + # add alpha="cluster"
theme_bw() + theme(legend.key=element_blank(),panel.border=element_blank(),strip.background=element_blank()) + scale_color_manual(drop=FALSE,values=colors,name="DE") +
scale_alpha_manual(values=c(1,1,1)) + # add
guides(alpha = guide_legend(override.aes = list(colour = cluster.cols, pch=0))) # add
g <- p+geom_polygon(data=hulls.df,aes(x=x,y=y,group=cluster), color=hulls.df$col,fill=NA)
What you are asking for is two colour scales. My understanding is that this is not possible. But you can give the impression of having two colour scales with a bit of a cheat and using the filled symbols (shapes 21 to 25).
p <- ggplot(df, aes(x = x, y = y, fill = interval)) +
geom_point(cex = 2, shape = 21, stroke = 1, colour = NA)+
labs(x = "X", y = "Y") +
theme_bw() +
theme(legend.key = element_blank(), panel.border = element_blank(), strip.background = element_blank()) +
scale_fill_manual(drop=FALSE, values=colors, name="DE") +
geom_polygon(data = hulls.df, aes(x = x, y = y, colour = cluster), fill = NA) +
scale_colour_manual(values = cluster.cols)
p
Alternatively, use a filled polygon with a low alpha
p <- ggplot(df,aes(x=x,y=y,colour=interval))+
geom_point(cex=2,shape=1,stroke=1)+
labs(x="X", y="Y")+
theme_bw() +
theme(legend.key = element_blank(),panel.border=element_blank(), strip.background=element_blank()) +
scale_color_manual(drop=FALSE,values=colors,name="DE", guide = guide_legend(override.aes = list(fill = NA))) +
geom_polygon(data=hulls.df,aes(x=x,y=y,group=cluster, fill = cluster), alpha = 0.2, show.legend = TRUE) +
scale_fill_manual(values = cluster.cols)
p
But this might make the point colours difficult to see.

Different size facets at x-axis

Length of x-axis is important for my plot because it allows one to compare between facets, therefore I want facets to have different x-axis sizes. Here is my example data:
group1 <- seq(1, 10, 2)
group2 <- seq(1, 20, 3)
x = c(group1, group2)
mydf <- data.frame (X =x , Y = rnorm (length (x),5,1),
groups = c(rep(1, length (group1)), rep(2, length(group2))))
And my code:
p1 = ggplot(data=mydf,aes(x=X,y=Y,color=factor(groups)) )+
geom_point(size=2)+
scale_x_continuous(labels=comma)+
theme_bw()
p1+facet_grid(groups ~ .,scales = "fixed",space="free_x")
And the resulting figure:
Panel-1 has x-axis values less then 10 whereas panel-2 has x-axis value extending to 20. Still both panels and have same size on x-axis. Is there any way to make x-axis panel size different for different panels, so that they correspond to their (x-axis) values?
I found an example from some different package that shows what I am trying to do, here is the figure:
Maybe something like this can get you started. There's still some formatting to do, though.
library(grid)
library(gridExtra)
library(dplyr)
library(ggplot2)
p1 <- ggplot(data=mydf[mydf$groups==1,],aes(x=X,y=Y))+
geom_point(size=2)+
theme_bw()
p2 <- ggplot(data=mydf[mydf$groups==2,],aes(x=X,y=Y))+
geom_point(size=2)+
theme_bw()
summ <- mydf %>% group_by(groups) %>% summarize(len=diff(range(X)))
summ$p <- summ$len/max(summ$len)
summ$q <- 1-summ$p
ng <- nullGrob()
grid.arrange(arrangeGrob(p1,ng,widths=summ[1,3:4]),
arrangeGrob(p2,ng,widths=summ[2,3:4]))
I'm sure there's a way to make this more general, and the axes don't line up perfectly yet, but it's a beginning.
Here is a solution following OP's clarifying comment ("I guess axis will be same but the boxes will be of variable size. Is it possible by plotting them separately and aligning in grid?").
library(plyr); library(ggplot2)
buffer <- 0.5 # Extra space around the box
#Calculate box parameters
mydf.box <- ddply(mydf, .(groups), summarise,
max.X = max(X) + buffer,
min.X = 0,
max.Y = max(Y) + buffer,
min.Y = 0,
X = mean(X), Y = mean(Y)) #Dummy values for X and Y needed for geom_rect
p2 <- ggplot(data=mydf,aes(x=X, y=Y) )+
geom_rect(data = mydf.box, aes( xmax = max.X, xmin = min.X,
ymax = max.Y, ymin = min.Y),
fill = "white", colour = "black", fill = NA) +
geom_point(size=2) + facet_grid(groups ~ .,scales = "free_y") +
theme_classic() +
#Extra formatting to make your plot like the example
theme(panel.background = element_rect(fill = "grey85"),
strip.text.y = element_text(angle = 0),
strip.background = element_rect(colour = NA, fill = "grey65"))

Resources