I'd like to take this kind of 16-bit TIFF image as input:
then turn the grayscale into rainbow pseudocolors like this:
and add a color key before exporting the resulting image again as TIFF image.
Is there a way to turn a grayscale image to a pseudocolor image in R?
Or, if you take gif as input:
library(caTools)
y <- read.gif("the.gif")
# create color palette based on brightness of colors (bright = red, dark = blue)
brightness <- colSums(col2rgb(y$col))
pal <- colorRampPalette(c("darkblue", "skyblue", "yellow", "red", "darkred"),
bias=1)(max(brightness)+1)
# prepare export
tiff("the.tiff", compression = "lzw")
par(mfrow=c(2,1), mar=rep(1,4))
# plot original image
image(y$image, col=y$col,
xaxt="n", yaxt="n", bty="n", asp = 1)
# plot rotated image with new pal below
image(apply(y$image, 1, rev), col=pal[brightness+1],
xaxt="n", yaxt="n", bty="n", asp = 1)
# create dummy legend with reduced 5 color palette
clusters <- kmeans(t(col2rgb(pal[brightness+1])),
centers = k <- 5)
legend(x="right", fill=rgb(clusters$centers/255),
legend=replicate(k,
paste(letters[sample(1:10, 5)],
collapse="")))
# export to tiff
dev.off()
I've worked out the following solution for this problem (using the following image http://www.biomedimaging.org/BookImages/GeneExpressionCy3.tif as an example). The following code reads the grayscale TIFF image, rotates it 90° counterclockwise and uses a colour palette to generate an image with pseudocolors.
library(tiff)
library(RColorBrewer)
img <- readTIFF("example.tif")
colnum <- 256
cols <- ceiling(img[,,1] * (colnum - 1) + 1)
# If img consists of a 2D-array: cols <- ceiling(img * (colnum - 1) + 1).
# Use cols <- ceiling(t(img[,,1] * (colnum - 1) + 1)) if you don't want to
# rotate the image.
#pal <- colorRampPalette(c("darkblue", "skyblue", "yellow", "red", "darkred"),
# bias = 1)(colnum) as suggested by #lukeA
pal <- colorRampPalette(brewer.pal(9, "YlOrBr"), space = 'rgb')(colnum)
# Create lookup-table to match the palette colours with the numeric values
lut <- data.frame(col = 1:colnum, pal, stringsAsFactors = FALSE)
cols2 <- lut[match(cols, lut[,1]),2]
dim(cols2) <- dim(cols)
img.width <- dim(cols)[1]
img.height <- dim(cols)[2]
tiff("example_coloured.tiff", width = img.width, height = img.height,
units = "px", res = 300)
layout(matrix(c(1,2), nrow = 1), widths = c(4,1), heights = c(4,4))
layout.show(2)
par(mar = c(0,0,0,0))
image(matrix(1:(img.height * img.width), ncol = img.height, nrow = img.width),
col = cols2, xaxt = "n", yaxt = "n", frame.plot = FALSE)
par(mar = c(0,0.1,0,0))
image(t(matrix(1:img.width, ncol = 1, nrow = img.width)),
col = pal, xaxt = "n", yaxt = "n", frame.plot = FALSE)
dev.off()
The only thing I'm still missing is how to add some text (e.g. -high / -low at the ends) to the colour key. I would be grateful for any hints.
Related
QUESTION: I am building a triplot for the results of my distance-based RDA in R, library(vegan). I can get a triplot to build, but can't figure out how to make the colours of my sites different based on their location. Code below.
#running the db-RDA
spe.rda.signif=capscale(species~canopy+gmpatch+site+year+Condition(pair), data=env, dist="bray")
#extract % explained by first 2 axes
perc <- round(100*(summary(spe.rda.signif)$cont$importance[2, 1:2]), 2)
#extract scores (coordinates in RDA space)
sc_si <- scores(spe.rda.signif, display="sites", choices=c(1,2), scaling=1)
sc_sp <- scores(spe.rda.signif, display="species", choices=c(1,2), scaling=1)
sc_bp <- scores(spe.rda.signif, display="bp", choices=c(1, 2), scaling=1)
#These are my location or site names that I want to use to define the colours of my points
site_names <-env$site
site_names
#set up blank plot with scaling, axes, and labels
plot(spe.rda.signif,
scaling = 1,
type = "none",
frame = FALSE,
xlim = c(-1,1),
ylim = c(-1,1),
main = "Triplot db-RDA - scaling 1",
xlab = paste0("db-RDA1 (", perc[1], "%)"),
ylab = paste0("db-RDA2 (", perc[2], "%)")
)
#add points for site scores - these are the ones that I want to be two different colours based on the labels in the original data, i.e., env$site or site_names defined above. I have copied the current state of the graph
points(sc_si,
pch = 21, # set shape (here, circle with a fill colour)
col = "black", # outline colour
bg = "steelblue", # fill colour
cex = 1.2) # size
Current graph
I am able to add species names and arrows for environmental predictors, but am just stuck on how to change the colour of the site points to reflect their location (I have two locations defined in my original data). I can get them labelled with text, but that is messy.
Any help appreciated!
I have tried separating shape or colour of point by site_name, but no luck.
If you only have a few groups (in your case, two), you could make the group a factor (within the plot call). In R, factors are represented as an integer "behind the scenes" - you can represent up to 8 colors in base R using a simple integer:
set.seed(123)
df <- data.frame(xvals = runif(100),
yvals = runif(100),
group = sample(c("A", "B"), 100, replace = TRUE))
plot(df[1:2], pch = 21, bg = as.factor(df$group),
bty = "n", xlim = c(-1, 2), ylim = c(-1, 2))
legend("topright", unique(df$group), pch = 21,
pt.bg = unique(as.factor(df$group)), bty = "n")
If you have more than 8 groups, or if you would like to define your own colors, you can simply create a vector of colors the length of your groups and still use the same factor method, though with a few slight tweaks:
# data with 10 groups
set.seed(123)
df <- data.frame(xvals = runif(100),
yvals = runif(100),
group = sample(LETTERS[1:10], 100, replace = TRUE))
# 10 group colors
ccols <- c("red", "orange", "blue", "steelblue", "maroon",
"purple", "green", "lightgreen", "salmon", "yellow")
plot(df[1:2], pch = 21, bg = ccols[as.factor(df$group)],
bty = "n", xlim = c(-1, 2), ylim = c(-1, 2))
legend("topright", unique(df$group), pch = 21,
pt.bg = ccols[unique(as.factor(df$group))], bty = "n")
For pch just a slight tweak to wrap it in as.numeric:
pchh <- c(21, 22)
ccols <- c("slateblue", "maroon")
plot(df[1:2], pch = pchh[as.numeric(as.factor(df$group))], bg = ccols[as.factor(df$group)],
bty = "n", xlim = c(-1, 2), ylim = c(-1, 2))
legend("topright", unique(df$group),
pch = pchh[unique(as.numeric(as.factor(df$group)))],
pt.bg = ccols[unique(as.factor(df$group))], bty = "n")
I am having a 3D plot in which the points are colored acording to some extra vector. My problem is to add a color gradient legend. This is my code:
x = matrix(NA,100,6)
#x value
x[,1] = runif(100, 0, 10)
#y value
x[,2] = runif(100, 0, 10)
#z value
x[,3] = x[,1]+x[,2]
#additional value
x[,4] = runif(100, 0, 1)
#find out in which interval each additional value is
intervals = seq(0,1,1/10)
x[,5] = findInterval(x[,4], intervals)
colours = topo.colors(length(intervals))
x[,6] = colours[x[,5]]
library(rgl)
plot3d(as.numeric(x[,1]),as.numeric(x.stab.in[,2]), as.numeric(x[,3]),
type="p", col=x[,6], size=2, xlab = "x(t)", ylab = "y(t)",
zlab = "z(t)")
decorate3d(xlab = "x", ylab = "y", zlab = "z")
legend3d("topright", legend = intervals, pch = 16, col = colours, cex=1, inset=c(0.02))
grid3d(c("x", "y+", "z"),col = "gray")
The plot looks like this
but I want the legend in a gradient form. That means I don't want separate points for each color but one box in which the colors fade into each other.
Here is a possible solution if you are okay with using scatterplot3d package instead of rgl. It is basically same but non-interactive. Here is your code modified to produce your expected result.
x = matrix(NA,100,6)
#x value
x[,1] = runif(100, 0, 10)
#y value
x[,2] = runif(100, 0, 10)
#z value
x[,3] = x[,1]+x[,2]
#additional value
x[,4] = runif(100, 0, 1)
#find out in which interval each additional value is
intervals = seq(0,1,1/10)
x[,5] = findInterval(x[,4], intervals)
#produce gradient of colors
#you can define different colors (two or more)
gradient <- colorRampPalette(colors = c("yellow", "green", "blue"))
colours <- gradient(length(intervals))
x[,6] = colours[x[,5]]
library(scatterplot3d)
png('3d.png', width = 600, height = 400)
layout(matrix(1:2, ncol=2), width = c(3, 1), height = c(1, 1))
scatterplot3d(as.numeric(x[,1]),as.numeric(x[,2]), as.numeric(x[,3]), type = 'p',
cex.symbols = 1.25, color=x[,6], pch = 16, xlab = "x(t)", ylab = "y(t)", zlab = "z(t)")
plot(x = rep(1, 100), y = seq_along(x[,6]),
pch = 15, cex = 2.5,
col = gradient(length(x[,6])),
ann = F, axes = F, xlim = c(1, 2))
axis(side = 2, at = seq(1, nrow(x), length.out = 11),
labels = 1:11,
line = 0.15)
dev.off()
This will plot the following graph
Here is another solution if you want to plot a gradient on an interactive 3d plot, such as if you needed to animate the plot into a movie.
require(car)
require(rgl)
require(RColorBrewer)
require(mgcv)
require(magick) #Only for creating the animation of the plot as a gif
#Creating mock dataset
Example_Data <- data.frame(Axis1 = rnorm(100),
Axis2 = rnorm(100),
Axis3 = rnorm(100))
Example_Data$Value <- Example_Data$Axis1+Example_Data$Axis2
#Defining function that takes a vector of numeric values and converts them to
#a spectrum of rgb colors to help color my scatter3d plot
get_colors <- function(values){
v <- (values - min(values))/diff(range(values))
x <- colorRamp(rev(brewer.pal(11, "Spectral")))(v)
rgb(x[,1], x[,2], x[,3], maxColorValue = 255)
}
#Writing function that takes a vector of numeric values and a title and creates
#a gradient legend based on those values and the title and suitable for addition
#to a scatter3d plot via a call to bgplot3d()
#Note, I didn't have time to make this automatically adjust text position/size for different size
#plot windows, so values may need to be adjusted manually depending on the size of the plot window.
gradient_legend_3d <- function(values, title){
min_val <- min(values)
max_val <- max(values)
x <- colorRamp(brewer.pal(11, "Spectral"))((0:20)/20)
colors <- rgb(x[,1], x[,2], x[,3], maxColorValue = 255)
legend_image <- as.raster(matrix(colors, ncol=1))
plot(c(0,1),c(0,1),type = 'n', axes = F,xlab = '', ylab = '', main = '') #Generates a blank plot
text(x=0.92, y = seq(0.5, 1,l=5), labels = signif(seq(min_val, max_val,l=5), 2), cex = 1.5) #Creates the numeric labels on the scale
text(x = 0.85, y = 1, labels = title, adj = 1, srt = 90, cex = 1.5) #Determines where the title is placed
rasterImage(legend_image, 0.87, 0.5, 0.9,1) #Values can be modified here to alter where and how wide/tall the gradient is drawn in the plotting area
}
#Creating scatter3d plot
scatter3d(x = Example_Data$Axis1, y = Example_Data$Axis2, z = Example_Data$Axis3, xlab = "Axis1", ylab = "Axis2", zlab = "Axis3", surface = F, grid = F, ellipsoid = F, fogtype = "none", point.col = get_colors(Example_Data$Value))
#Changing size of plotting window and orientation to optimize for addition of static legend
#This may not work on another machine, so the window may need to be adjusted manually
par3d(windowRect = c(0,23,1536,824))
par3d(userMatrix = matrix(c(-0.98181450, -0.02413967, 0.18830180, 0, -0.03652956, 0.99736959, -0.06260729, 0, -0.18629514, -0.06834736, -0.98011345, 0, 0, 0, 0, 1), nrow = 4, ncol = 4, byrow = T))
#Adding legend
bgplot3d(gradient_legend_3d(Example_Data$Value, "Point Value"))
#Animating plot and saving as gif
movie3d(spin3d(axis = c(0,1,0), rpm = 5), duration = 12, dir = getwd(), fps = 5, convert = FALSE, clean = FALSE)
frames <- NULL
for(j in 0:60){
if(j == 1){
frames <- image_read(sprintf("%s%03d.png", "movie", j))
} else {
frames <- c(frames, image_read(sprintf("%s%03d.png", "movie", j)))
}
}
animation <- image_animate(frames, fps = 10, optimize = TRUE)
image_write(animation, path = "Example.gif")
for(j in 0:60){
unlink(sprintf("%s%03d.png", "movie", j))
}
See link to view 3d plot generated by this code:
gif of 3d plot with gradient color scale
I'm using base R plot(), and I want a legend (a color block and key) to show up above (outside) the top right of my plot next to my title (generated using title()).
What's the best way to do this?
Maybe something like this is what you're looking for:
x <- c(1,2,3,4)
y <- c(4,1,3,2)
z <- c(1,2,3,4)
dat <- data.frame(x,y,z)
windows(width = 5, height = 9) #quartz() on Mac
layout(matrix(c(1,2), 2, 1, byrow = TRUE), heights=c(0.5,1))
par(oma = c(4,3,0,0) + 0.1, mar = c(0,0,1,1) + 0.1)
plot(dat$x, y=rep(1,4), type = "n", axes = F, ylab = "", xlab = "")
legend(x = "bottomright", legend = c("y", "z"), fill = c("blue", "red"))
plot(dat$x, dat$y, type = "n", main = "PLOT")
lines(z, col = "red")
lines(y, col = "blue")
Basically this makes two plots, one is just invisible and shortened so all that's displayed is the legend.
You may be able to addtionally tweak the margins around the legend and other graphical parameters (?par) to get the layout better.
I am looking for a way to do a (actually quite common) visualization, whereby the split of a population of, say, N units into several categories is shown via a set of N pictograms - I'd prefer filled squares; in a newspaper, etc., one might see little humanoid shapes - with each pictogram colored according to the category of n'th unit. N fixed to 1 or 100, and the chart displaying fractions or percentages rather than counts, would be OK. The colored "stripes" would have to wrap to multiple lines. Is anyone aware of this chart available in an R package?
To take a specific example,
x = sample(c("A","B"),100,replace = T)
I would like to see a 10x10 (or 5x20, or whatever) grid of colored squares, some - corresponding to "A" - colored green, others red. The green (and likewise red) squares could be "bunched", or left in the original order.
Thank you.
Below we show 3 versions. The first uses squares, the next uses circles, the next uses an icon of a man and finally we use smiley faces.
Squares
# input data
set.seed(123)
x <- sample(c("A","B"),100,replace = T)
# input parameters - nr * nc should equal length(x)
cols <- c("green", "red")
nr <- 10
nc <- 10
# create data.frame of positions and colors
m <- matrix(cols[factor(x)], nr, nc)
DF <- data.frame(row = c(row(m)), col = c(col(m)[, nc:1]), value = c(m),
stringsAsFactors = FALSE)
# plot squares - modify cex to get different sized squares
plot(col ~ row, DF, col = DF$value, pch = 15, cex = 4, asp = 1,
xlim = c(0, nr), ylim = c(0, nc),
axes = FALSE, xlab = "", ylab = "")
Circles
# plot circles
plot(col ~ row, DF, col = DF$value, pch = 20, cex = 6, asp = 1,
xlim = c(0, nr), ylim = c(0, nc),
axes = FALSE, xlab = "", ylab = "")
png Icons This solution uses a black/white icon of a man which we have assumed has been saved in the current directory as man.png. We color it red and green and use those two versions in place of the squares or circles:
# blank graph to insert man icons into
plot(col ~ row, DF, col = DF$value, asp = 1,
xlim = c(0, nr), ylim = c(0, nc),
axes = FALSE, xlab = "", ylab = "", type = "n")
library(png)
man <- readPNG("man.png")
red.man <- man
red.man[,,1] <- man[,,4] # fill in red dimension
R <- subset(DF, value == "red")
with(R, rasterImage(red.man,
row-.5, col-.5, row+.5, col+.5,
xlim = c(0, nr), ylim = c(0, nc),
xlab = "", ylab = ""))
green.man <- man
green.man[,,2] <- man[,,4] # fill in green dimension
G <- subset(DF, value == "green")
with(G, rasterImage(green.man,
row-.5, col-.5, row+.5, col+.5,
xlim = c(0, nr), ylim = c(0, nc),
xlab = "", ylab = ""))
Smiley Face Icons This solution uses a green smiley face icon and a red frowning face icon which we have assumed have been saved in the
current directory as smiley_green.jpg and smiley_red.jpg.
# blank graph to insert man icons into
xp <- 1.25
plot(col ~ row, DF, col = DF$value, asp = 1,
xlim = c(0, xp * nr), ylim = c(0, xp * nc),
axes = FALSE, xlab = "", ylab = "", type = "n")
library(jpeg)
smiley_green <- readJPEG("smiley_green.jpg")
smiley_red <- readJPEG("smiley_red.jpg")
R <- subset(transform(DF, row = xp * row, col = xp * col), value == "red")
with(R, rasterImage(smiley_red,
row - .5, col - .5, row + .5, col + .5,
xlim = c(0, xp * nr), ylim = c(0, xp * nc),
xlab = "", ylab = ""))
G <- subset(transform(DF, row = xp * row, col = xp * col), value == "green")
with(G, rasterImage(smiley_green,
row - .5, col - .5, row + .5, col + .5,
xlim = c(0, xp * nr), ylim = c(0, xp * nc),
xlab = "", ylab = ""))
Revised To 10x10 green/red and added version using man icon.
BINGO. My prayers have been answered with
http://rud.is/b/2015/03/18/making-waffle-charts-in-r-with-the-new-waffle-package/
(But many thanks for the solutions suggested earlier).
# devtools::install_github("hrbrmstr/waffle")
library(waffle)
x <- sample(c("A","B"),100,replace = T)
x <- c(A=sum(x=="A"), B=sum(x=="B"))
waffle(x, rows=10, colors=c("red", "green"))
I also made a package for this (nigh-simultaneously with that other guy :-). It has three approaches, using geom_tile, geom_text (use e.g. FontAwesome for icons) and geom_point. The latter two can do drop shadows, but you have to tinker with the settings sometimes. There's some more examples here.
devtools::install_github("rubenarslan/formr")
library(formr)
qplot_waffle(rep(1:3,each=40,length.out=90))
library(ggplot2)
qplot_waffle_text(rep(1, each = 30), symbol = "", rows = 3) + ggtitle("Number of travellers in 2008")
The OP requested a ggplot2 solution on the ggplot2 Google group, so I'm posting it here as well:
ggplot(DF, aes(row, col, fill=value)) +
geom_tile(colour="white", lwd=2) +
scale_fill_manual(values=c("green","red")) +
theme(panel.background=element_blank(),
axis.text=element_blank(),
axis.ticks=element_blank(),
axis.title=element_blank()) +
guides(fill=FALSE)
I have to plot some plot(x,y) scatters, but i would like the points to be color coded based on the value of a continuous variable z.
I would like a temperature palette (from dark blue to bright red). I tried with Rcolorbrewer however the the RdBu palette (which resembles the temperature palette) uses white for the middle values which looks very bad.
I would also like to plot a legend explaining the color coding with a sample of colors and corresponding values.
Any ideas if this can be performed easily in R? No ggplot please!
Season greetings to everybody
Building off of #BenBolker's answer, you can do the legend if you take a peek at the code for filled.contour. I hacked that function apart to look like this:
scatter.fill <- function (x, y, z,
nlevels = 20, plot.title, plot.axes,
key.title, key.axes, asp = NA, xaxs = "i",
yaxs = "i", las = 1,
axes = TRUE, frame.plot = axes, ...)
{
mar.orig <- (par.orig <- par(c("mar", "las", "mfrow")))$mar
on.exit(par(par.orig))
w <- (3 + mar.orig[2L]) * par("csi") * 2.54
layout(matrix(c(2, 1), ncol = 2L), widths = c(1, lcm(w)))
par(las = las)
mar <- mar.orig
mar[4L] <- mar[2L]
mar[2L] <- 1
par(mar = mar)
#Some simplified level/color picking
levels <- seq(min(z),max(z),length.out = nlevels)
col <- colorRampPalette(c("blue","red"))(nlevels)[rank(z)]
plot.new()
plot.window(xlim = c(0, 1), ylim = range(levels), xaxs = "i",
yaxs = "i")
rect(0, levels[-length(levels)], 1, levels[-1L], col = colorRampPalette(c("blue","red"))(nlevels)
if (missing(key.axes)) {
if (axes)
axis(4)
}
else key.axes
box()
if (!missing(key.title))
key.title
mar <- mar.orig
mar[4L] <- 1
par(mar = mar)
#Simplified scatter plot construction
plot(x,y,type = "n")
points(x,y,col = col,...)
if (missing(plot.axes)) {
if (axes) {
title(main = "", xlab = "", ylab = "")
Axis(x, side = 1)
Axis(y, side = 2)
}
}
else plot.axes
if (frame.plot)
box()
if (missing(plot.title))
title(...)
else plot.title
invisible()
}
And then applying the code from Ben's example we get this:
x <- runif(40)
y <- runif(40)
z <- runif(40)
scatter.fill(x,y,z,nlevels = 40,pch = 20)
which produces a plot like this:
Fair warning, I really did just hack apart the code for filled.contour. You will likely want to inspect the remaining code and remove unused bits, or fix parts that I rendered non-functional.
Here some home-made code to achieve it with default packages (base, graphics, grDevices) :
# Some data
x <- 1:1000
y <- rnorm(1000)
z <- 1:1000
# colorRamp produces custom palettes, but needs values between 0 and 1
colorFunction <- colorRamp(c("darkblue", "black", "red"))
zScaled <- (z - min(z)) / (max(z) - min(z))
# Apply colorRamp and switch to hexadecimal representation
zMatrix <- colorFunction(zScaled)
zColors <- rgb(zMatrix, maxColorValue=255)
# Let's plot
plot(x=x, y=y, col=zColors, pch="+")
For StanLe, here is the corresponding legend (to be added by layout or something similar) :
# Resolution of the legend
n <- 10
# colorRampPalette produces colors in the same way than colorRamp
plot(x=NA, y=NA, xlim=c(0,n), ylim=0:1, xaxt="n", yaxt="n", xlab="z", ylab="")
pal <- colorRampPalette(c("darkblue", "black", "red"))(n)
rect(xleft=0:(n-1), xright=1:n, ybottom=0, ytop=1, col=pal)
# Custom axis ticks (consider pretty() for an automated generation)
lab <- c(1, 500, 1000)
at <- (lab - min(z)) / (max(z) - min(z)) * n
axis(side=1, at=at, labels=lab)
This is a reasonable solution -- I used blue rather than dark blue for the starting point, but you can check out ?rgb etc. to adjust the color to your liking.
nbrk <- 30
x <- runif(20)
y <- runif(20)
cc <- colorRampPalette(c("blue","red"))(nbrk)
z <- runif(20)
plot(x,y,col=cc[cut(z,nbrk)],pch=16)