I have this tab called x:
I use it to make this plot, using the script:
lg <- x[1,2]
plot(1, type="n", xlab=contig, ylab="Best hits", xlim=c(-200, lg), ylim=c(0, 11))
segments(0,0,lg,0, col="red", lwd=3)
for (i in 1:10) {
segments(x[i,3],i,x[i,4],i); text(x=(x[i,4]-x[i,5]/2),y=i+0.2,labels=paste(x[i,6],"-",x[i,13], "%"))
}
But I'd like to have the text (starting by "NW_...") to be colored in the plot so that each unique text has its own color.
Here since there are 5 unique "NW_", there would be five colors.
I tried:
lg <- x[1,2]
plot(1, type="n", xlab=contig, ylab="Best hits", xlim=c(-200, lg), ylim=c(0, 11))
segments(0,0,lg,0, col="red", lwd=3)
for (i in 1:10) {
segments(x[i,3],i,x[i,4],i); text(x=(x[i,4]-x[i,5]/2),y=i+0.2,labels=paste(x[i,6],"-",x[i,13], "%"), col=rainbow(n=nlevels(x$TID))[x$TID])
}
But this fails.
Actually, I have no clue how to make this in a loop.
Could you help?
Thanks!
Muriel
add a colour column to x.
x$colour <- rainbow(nlevels(x$TID))[x$TID]
Then use this colour in your for loop.
lg <- x[1,2]
plot(1, type="n", xlab=contig, ylab="Best hits", xlim=c(-200, lg), ylim=c(0, 11))
segments(0,0,lg,0, col="red", lwd=3)
for (i in 1:10) {
segments(x[i, 3], i, x[i, 4], i)
text(
x = (x[i, 4] - x[i, 5] / 2),
y = i + 0.2,
labels = paste(x[i, 6], "-", x[i, 13], "%"),
col=x[i, "colour"])
}
Related
I have a line graph time series and I wanna make a filling color red for positive y values and blue for negative y values. How can i do it using polygon function because iam not using ggplot?
Thank you!
plot(ts.NAO$NAO_index, type="l",ann=FALSE, xaxt="n", yaxt="n",xlim=c(0,123))
par(new=TRUE)
plot(running_mean, type="l",
lty=2, lwd=2, col="red", ann=FALSE, xaxt="n", yaxt="n")
title(xlab="Years", ylab="NAO SLP Index")
abline(h=0, col="blue")
axis(side=1, at=seq(1,123,10), labels=seq(1900,2020,10), las=1) # customizing the x axis
axis(side=2, at=seq(-6,6,0.5), labels=seq(-6,6,0.5)) # customizing the y axis
polygon(c(ts.NAO$Year,rev(ts.NAO$Year),
c(ts.NAO$NAO_index,rev(ts.NAO$NAO_index),
col = "darkgreen",border=NA)))
Sample data,
set.seed(2022)
dat <- data.frame(x=1:100, y=cumsum(runif(100, -10, 10)))
head(dat)
# x y
# 1 1 8.296121
# 2 2 17.037629
# 3 3 12.760420
# 4 4 19.369372
# 5 5 22.204283
# 6 6 22.586202
First cut: we'll split the sequence into blocks of neg/pos, then plot each polygon. (data.table::rleid works well, if you must use something else we can contrive a naive version that does the same thing.
my_rleid <- function(z) {
r <- rle(z)
rep.int(seq_along(r$lengths), times = r$lengths)
} # or you can use data.table::rleid
spl <- split(dat, my_rleid(dat$y < 0))
lapply(spl[1:2], head)
# $`1`
# x y
# 1 1 6.319553
# 2 2 9.264740
# 3 3 1.671311
# 4 4 2.547314
# $`2`
# x y
# 5 5 -3.758086
# 6 6 -1.042269
# 7 7 -9.556289
# 8 8 -18.716770
# 9 9 -21.310428
# 10 10 -16.165370
miny <- min(dat$y)
plot(y ~ x, data = dat, type = "l")
abline(h = 0, lty = 2)
for (Z in spl) {
polygon(Z$x[c(1, 1:nrow(Z), nrow(Z))], c(miny, Z$y, miny),
col = if (Z$y[1] < 0) "red" else "blue")
}
As you can see, we need to extend each element of spl to extend to the next block (since the x values will show a gap). There are many options for this depending on your preferences: carry-forward (add a row to the bottom of each), push-backward (add a row to the top of each from the preceding block), or interpolate between the first row in one with the bottom row in the preceding. I think the first two are fairly simple, I'll opt for the more-difficult (but visually more consistent) one of interpolation.
for (ind in 2:length(spl)) {
x1 <- spl[[ind-1]]
x2 <- spl[[ind]]
newdat <- do.call(approx, c(setNames(rbind(x1[nrow(x1),], x2[1,]), c("y", "x")), list(xout = 0)))
names(newdat) <- c("y", "x")
newdat <- data.frame(newdat)[,2:1]
spl[[ind-1]] <- rbind(spl[[ind-1]], newdat)
spl[[ind]] <- rbind(newdat, spl[[ind]])
}
plot(y ~ x, data = dat, type = "l")
abline(h = 0, lty = 2)
for (Z in spl) {
polygon(Z$x[c(1, 1:nrow(Z), nrow(Z))], c(miny, Z$y, miny),
col = if (mean(Z$y) < 0) "red" else "blue")
}
(Note that the col= conditional changed, since we know that the first value should "always" be 0.)
Edit: I assumed making the polygon start at the bottom of the plot, as defined by miny <- min(dat$y). As a cue from AllanCameron's excellent answer, if you set miny <- 0 instead, you get this:
My guess is you are looking for something like this. Create two new series in your data frame - one that is 0 if the y value is negative, and another that is 0 if your y value is positive. Bookend both these series with 0 values. You can then use these two series as the outlines of your polygons:
Thanks ro r2evans for the dataset, which I have modified somewhat to make it more in keeping with the ranges of the OP's data.
set.seed(2022)
dat <- data.frame(x = 1:123, y = cumsum(runif(123, -1.5, 1.5)))
dat$y_up <- ifelse(dat$y > 0, dat$y, 0)
dat$y_dn <- ifelse(dat$y < 0, dat$y, 0)
plot(dat$x, dat$y, type = "l", ann = FALSE, xaxt = "n", yaxt = "n")
title(xlab = "Years", ylab = "NAO SLP Index")
abline(h = 0)
axis(side = 1, at = seq(1, 123, 10), labels = seq(1900, 2020, 10), las = 1)
axis(side = 2, at = seq(-6, 6, 0.5), labels = seq(-6, 6, 0.5))
polygon(c(dat$x[1], dat$x, tail(dat$x, 1)), c(0, dat$y_up, 0), col = "red")
polygon(c(dat$x[1], dat$x, tail(dat$x, 1)), c(0, dat$y_dn, 0), col = "blue")
Created on 2022-12-23 with reprex v2.0.2
Here's an alternative approach. Instead of dividing the time series into many polygons I decided to draw everything at once (well, twice actually) and limit the plotting region instead.
Generating data and initial plotting:
# random data
set.seed(1)
ts.NAO <- list(NAO_index=rnorm(123, sd=2))
running_mean <- stats::filter(ts.NAO$NAO_index, rep(1, 7)/7)
plot(ts.NAO$NAO_index, type='n', ann=F, xaxt='n', yaxt='n', xlim=c(0, 123))
title(xlab="Years", ylab="NAO SLP Index")
axis(side=1, at=seq(1,123,10), labels=seq(1900,2020,10), las=1) # customizing the x axis
axis(side=2, at=seq(-6,6,0.5), labels=seq(-6,6,0.5)) # customizing the y axis
# save for later use
par0 <- par(c('usr', 'mar'))
# vertical value of dividing point between red and blue
split.at <- 0
# normalized device coordinates of plotting region x and y limits and
# the split point
coords <- list(x=grconvertX(par0$usr[1:2], to='ndc'),
y=grconvertY(c(par0$usr[3:4], split.at), to='ndc'))
Here's a function that creates the lower or upper subfigure and draws the polygon. I didn't want to repeat some parts of code twice, hence the function (although it would be shorter without it).
sub_fig <- function(upper=T, color='red') {
if (upper) {
y.fig <- coords$y[3:2] # subfigure bottom and top
y.usr <- c(split.at, par0$usr[4]) # plot y limits
} else {
y.fig <- coords$y[c(1, 3)]
y.usr <- c(par0$usr[3], split.at)
}
par(fig=c(coords$x, y.fig), mar=rep(0, 4), new=T)
frame()
plot.window(par0$usr[1:2], y.usr, xaxs='i', yaxs='i')
polygon(c(1, seq_along(ts.NAO$NAO_index), length(ts.NAO$NAO_index)),
c(split.at, ts.NAO$NAO_index, split.at),
col=color)
}
# upper
sub_fig()
# lower
sub_fig(F, 'blue')
# restore initial plot coordinates
par(fig=c(0, 1, 0, 1), mar=par0$mar, new=T)
frame()
plot.window(par0$usr[1:2], par0$usr[3:4], xaxs='i', yaxs='i')
abline(h=0, col="blue")
lines(running_mean, col=gray(.7), lty=2, lwd=2)
An alternative approach using bars.
set.seed(2022)
dat <- data.frame(x = seq(1900, 2022, 1), y = cumsum(runif(123, -1.5, 1.5)))
dat$col <- ifelse(dat$y < 0, "blue3", "red3")
bp <- barplot(dat$y, border=F, col=dat$col, space=0, xlab="Year", ylab="Index")
lines(bp, dat$y, col="gray45")
lines(bp, rnorm(nrow(dat), 1.5, 0.3), lt=2, col="red2")
abline(h=0, col="blue")
axis(1, bp[c(T, rep(F, 9))], labels=dat$x[c(T,rep(F, 9))])
box()
plot(ts.NAO$Year, ts.NAO$NAO_index, type="l", xaxt="n", yaxt="n", xlim=c(1900,2020))
par(new=TRUE)
plot(ts.NAO$Year, running_mean, type="l", lty=2, lwd=2, col="red", xaxt="n", yaxt="n")
title(xlab="Years", ylab="NAO SLP Index")
abline(h=0, col="blue")
axis(side=1, at=seq(1900,2020,10), labels=seq(1900,2020,10), las=1)
axis(side=2, at=seq(-6,6,0.5), labels=seq(-6,6,0.5))
for (i in 1:length(ts.NAO$NAO_index)) {
if (ts.NAO$NAO_index[i] > 0) {
polygon(c(ts.NAO$Year[i], ts.NAO$Year[i+1], ts.NAO$Year[i+1], ts.NAO$Year[i]),
c(0, 0, ts.NAO$NAO_index[i], ts.NAO$NAO_index[i]),
col="red", border=NA)
} else {
polygon(c(ts.NAO$Year[i], ts.NAO$Year[i+1], ts.NAO$Year[i+1], ts.NAO$Year[i]),
c(0, 0, ts.NAO$NAO_index[i], ts.NAO$NAO_index[i]),
col="blue", border=NA)
}#you can choose to remove the polygon borders which is standard
#practice for presentation purposes where I work, certainly not
#the best way by any means
}
I've made a beeswarm plot in R by basically looping through groups in my data and creating a beeswarm for each group and combining into one plot:
#Build color field
color.By.Category <- function(x) {
if (x == "Polydrug") {
return("red")
} else if (x == "Opioid") {
return("blue")
} else if (x == "Cocaine") {
return("green")
} else if (x == "Gabapentin") {
return("orange")
} else if (x == "Meth") {
return("blue")
} else if (x == "Benzo") {
return("pink")
} else {
return("black")
}
}
# Make 5 rows, the first is the legend
par(mfrow=c(5,1), mar=c(0,10,0,0), oma=c(10,0,5,2), bg="black")
# Build legend
drug.categories <- unique(death.data.2$drug)
colr <- sapply(drug.categories, color.By.Category)
xleg <- seq(-10,110, by=23)
beeswarm(xleg, pwcol=colr,
horizontal = TRUE,
pch=15,
method="center",
cex=1,
xlim=c(-10,110),
ylim=c(-10,4))
text(x=xleg+0, y=.5, labels=toupper(drug.categories), col="white", pos=4, cex=1.1)
races <- unique(death.data.2$race)
for (i in 1:length(races)) {
# Subset to race/ethnicity
current <- death.data.2[death.data.2$race == races[i],]
# Draw the symbols
beeswarm(current$age, pwcol=current$color,
pch=15, method="center",
cex=1, horizontal=TRUE,
ylim=c(-10,10), xlim=c(0,100), axes=FALSE)
# label
mtext(races[i], side = 2, las=1, col="white", cex=.9)
}
x <- seq(0, 100, 5)
axis(side = 1, labels = x, at=x, col="black", col.ticks = "white")
mtext(x, side = 1, outer=FALSE, at=x, line=.8, col="white", cex=.8)
mtext("Age", side=1, at=x[1], outer=FALSE, col="white", line=2, adj=0.05, padj=.5, cex=.8)
# Title
mtext("Overdose Deaths by Substance Type", side=3, outer=TRUE, line=1, cex=1.5, col="white")
Which looks like this:
You can see there are weird gaps (i.e. blank lanes) where no data is showing, which almost looks like some kind of artifact from how the plot is rendering. What's going on here?
I believe you can remove the gaps by setting breaks = NA in your "Draw the symbols" beeswarm() call. The help file ?beeswarm tells us
breaks Breakpoints (optional). If NULL, breakpoints are chosen
automatically. If NA, bins are not used (similar to stripchart with
method = "stack").
So when the breaks = NA the binning behavior is prevented and the gaps should not appear.
# Draw the symbols
beeswarm(current$age, pwcol=current$color,
pch=15, method="center",
cex=1, horizontal=TRUE,
ylim=c(-10,10), xlim=c(0,100), axes=FALSE, breaks = NA)
I am working in RStudio and trying to make a 3x3 grid of the triangle plots built with the functions below. I’ve included a reproducible example, and the error I am running into is that the margins are too large to plot multiple plot, even though I am reducing the width and height.
I’ve also tried saving these as png and loading them in to arrange with cowplot, but the figure is very blurry and I’m not sure how to adjust the text size or line thickness to make the figures more legible.
#Data
iris$nrm.Sepal <- iris$Sepal.Width / iris$Sepal.Length
iris$nrm.Petal <- iris$Petal.Width / iris$Petal.Length
df_list <- split(iris, (iris$Species))
top.triangle <- function() {
plot(my.y ~ my.x, data= my.data, axes=FALSE, ylab='', xlab="",
main='', xlim=c(0, 1), ylim=c(0, 1), xaxt="n", yaxt="n", asp=1)
mtext("Here could be your title", 3, 5, font=2, cex=1.3, adj=.95)
mtext("Position.2", 2, .75)
mtext("Position.1", 3, 2)
axis(side=2, las=1, pos=0)
axis(side=3, las=1, pos=1)
lines(0:1, 0:1)
}
bottom.triangle <- function() {
points(my.x ~ my.y, data=my.data.2, xpd=TRUE)
mtext("Position.2", 1, 1.5, at=mean(par()$usr[1:2]) + x.dist)
mtext("Position.1", 4, 3, padj=par()$usr[1] + 10)
x.at <- axisTicks(par()$usr[1:2], 0) + x.dist
axis(side=1, las=1, pos=0, at=x.at,
labels=F, xpd=TRUE)
mtext(seq(0, 1, .2), 1, 0, at=x.at)
axis(4, las=1, pos=1 + x.dist)
lines(0:1 + x.dist, 0:1, xpd=TRUE)
}
#loop for generating species specific plots
for(i in 1:(length(df_list))){
current.strain <- as.character(df_list[[i]]$Species[1])
#declare file for saving png
# png(paste0("~.test.triangle_", current.strain, ".png"), width=650, height=500)
plot.new()
my.data = iris
my.x.top = (iris %>% filter(Species == current.strain) )$nrm.Petal
my.y.top = (iris %>% filter(Species == current.strain) )$nrm.Sepal
my.x.bottom = (iris %>% filter(Species == current.strain) )$nrm.Petal
my.y.bottom = (iris %>% filter(Species == current.strain) )$nrm.Sepal
op <- par(mar=c(3, 2, 2, 2) + 0.1, oma=c(2, 0, 0, 2))
top.triangle(my.y.top, my.x.top, my.data)
bottom.triangle(my.y.bottom+x.dist, my.x.bottom, my.data)
par(op)
RP[[i]] <- recordPlot()
dev.off()
}
#for margins too large error
graphics.off()
par("mar")
par(mar=c(.1,.1,.1,.1))
#draw and arrange the plots
ggdraw() +
draw_plot(RP[[1]], x=0, y=0)
#Add remaining plots
#draw_plot(RP[[2]], x=.25, y=.25)
#draw_plot(RP[[3]], x=.25, y=.25)
(this is built off the answer I posted from this question, R base plot, combine mirrored right triangles )
To use plot solution at specified link, you need to adjust to the iris data including your calculated columns, nrm.Sepal and nrm.Petal inside both functions. Then, instead of split, consider by to pass subsets into both functions for plotting. However, the plot will only generate 1 X 3. It is unclear how 3 X 3 is generated. Your posted link above actually duplicates
Data
iris$nrm.Sepal <- iris$Sepal.Width / iris$Sepal.Length
iris$nrm.Petal <- iris$Petal.Width / iris$Petal.Length
Functions
top.triangle <- function(my.data) {
plot(nrm.Sepal ~ nrm.Petal, data= my.data, axes=FALSE, ylab="", xlab="",
main='', xlim=c(0, 1), ylim=c(0, 1), xaxt="n", yaxt="n", asp=1)
mtext(my.data$Species[[1]], 3, 5, font=2, cex=1.3, adj=.95)
mtext("Position.2", 2, .75)
mtext("Position.1", 3, 2)
axis(side=2, las=1, pos=0)
axis(side=3, las=1, pos=1)
lines(0:1, 0:1)
}
bottom.triangle <- function(my.data) {
x.dist <- .5
my.data.2 <- transform(my.data, nrm.Sepal=nrm.Sepal + x.dist)
points(nrm.Petal ~ nrm.Sepal, data=my.data.2, col="red", xpd=TRUE)
mtext("Position.2", 1, 1.5, at=mean(par()$usr[1:2]) + x.dist)
mtext("Position.1", 4, 3, padj=par()$usr[1] + 3)
x.at <- axisTicks(par()$usr[1:2], 0) + x.dist
axis(side=1, las=1, pos=0, at=x.at,
labels=FALSE, xpd=TRUE)
mtext(seq(0, 1, 0.2), 1, 0, at=x.at, cex=0.7)
axis(4, las=1, pos=1 + x.dist)
lines(0:1 + x.dist, 0:1, xpd=TRUE)
}
Plot
par(mar=c(1, 4, 8, 6), oma=c(2, 0, 0, 2), mfrow=c(2,3))
by(iris, iris$Species, function(sub){
top.triangle(sub)
bottom.triangle(sub)
})
I am making a graph using these datas:
Upper_limit_graph_wt <- (((log(8)/50:5000)-log(d_wt))/log(g_wt))
Lower_limit_graph_wt <- (((log(1/8)/50:5000)-log(d_wt))/log(g_wt))
plot(Upper_limit_graph_wt, type="l", ylim=g_range, xlim=range(0:5000), ann=FALSE, col="pink")
par(new=TRUE)
plot(Lower_limit_graph_wt, type="l", ylim=g_range, xlim=range(0:5000), ann=FALSE, col="gold")
par(new=TRUE)
plot(Total_count, (Alt_count/Total_count), pch=16, ann=FALSE, ylim=g_range, xlim=range(0:5000), col="dark green")
I can't add an image but I basically get a graph with 2 curves and 1 dot.
The coordinates for my dot are x=Total_count and y=(Alt_count/Total_count)
However I don't seem to be able to add the function if else
When I do :
if((Total_count, (Alt_count/Total_count))> Upper_limit_graph)print"Fail"
It tells me "," was unexpected
How do I make it print something when my dot is above my curves?
Thanks
You should use text to add the text to your plot. Please see as follows:
d_wt <- 2
g_wt <- 3
Upper_limit_graph_wt <- (((log(8) / 50:5000) - log(d_wt)) / log(g_wt))
Lower_limit_graph_wt <- (((log(1/8)/50:5000) - log(d_wt)) / log(g_wt))
g_range <- seq_along(Upper_limit_graph_wt)
plot(c(Lower_limit_graph_wt, Upper_limit_graph_wt), xlim = range(g_range), type = "n")
lines(Lower_limit_graph_wt)
lines(Upper_limit_graph_wt)
Total_count <- 1000
Alt_count <- -600
points(Total_count, Alt_count/Total_count, cex = 2, col = "blue", pch = 19)
text(2000, -0.62,
ifelse((Alt_count / Total_count > Upper_limit_graph_wt[Total_count]), "Fail", ""),
col = "red")
Output:
I'm trying to achieve a similar plot to this one, using R's native plot command.
I was able to get something similar with the code below, however, I'd like the density polygons to overlap. Can anyone suggest a way to do this?
data = lapply(1:5, function(x) density(rnorm(100, mean = x)))
par(mfrow=c(5,1))
for(i in 1:length(data)){
plot(data[[i]], xaxt='n', yaxt='n', main='', xlim=c(-2, 8), xlab='', ylab='', bty='n', lwd=1)
polygon(data[[i]], col=rgb(0,0,0,.4), border=NA)
abline(h=0, lwd=0.5)
}
Outputs:
I would do it something like the following. I plot the densities in the same plot but add an integer to the y values. To make them overlapping i multiply by a constant factor fac.
# Create your toy data
data <- lapply(1:5, function(x) density(rnorm(100, mean = x)))
fac <- 5 # A factor to make the densities overlap
# We make a empty plot
plot(1, type = "n", xlim = c(-3, 10), ylim = c(1, length(data) + 2),
axes = FALSE, xlab = "", ylab = "")
# Add each density, shifted by i and scaled by fac
for(i in 1:length(data)){
lines( data[[i]]$x, fac*data[[i]]$y + i)
polygon(data[[i]]$x, fac*data[[i]]$y + i, col = rgb(0, 0, 0, 0.4), border = NA)
abline(h = i, lwd = 0.5)
}
(Note: This content was previously edited into the Question and was written by #by0.)
Thanks to #AEBilgrau, I quickly put together this function which works really nicely. Note: you need to play around with the factor fac depending on your data.
stacked.density <- function(data, fac = 3, xlim, col = 'black',
alpha = 0.4, show.xaxis = T,
xlab = '', ylab = ''){
xvals = unlist(lapply(data, function(d) d$x))
if(missing(xlim)) xlim=c(min(xvals), max(xvals))
col = sapply(col, col2alpha, alpha)
if(length(col) == 1) col = rep(col, length(data))
plot(1, type = "n", xlim = xlim, ylim = c(1,length(data) + 2),
yaxt='n', bty='n', xaxt=ifelse(show.xaxis, 'l', 'n'), xlab = xlab, ylab = ylab)
z = length(data):1
for(i in 1:length(data)){
d = data[[ z[i] ]]
lines(d$x, fac*d$y + i, lwd=1)
polygon(d$x, fac*d$y+ i, col=col[i], border=NA)
abline(h = i, lwd=0.5)
}
}
data <- lapply(1:5, function(x) density(rnorm(100, mean = x)))
stacked.density(data, col=c('red', 'purple', 'blue', 'green', 'yellow'), alpha=0.3, show.xaxis=T)
outputs: