Edited below with complete and functioning code:
I am trying to create a timeline similar to the one this code creates from the Timeline package, however, the options are not very flexible. For example, I would like to create space between each bar so they are not touching. Also, I am wondering if there is a way to add the "End_Status" column to the graph so that it it is obvious that the data stops there because the animal died. Any help is greatly appreciated.
Example dataset:
df <- data.frame(id = c(rep(1201, 10), rep(1202, 14), rep(1203, 6), rep(1204, 22)),
date = c(seq(1,5,1), seq(5,7,1), seq(7,8,1), seq(2,5,1), seq(7,9,1), seq(11,17,1), seq(1,8,1), seq(8,12, 1), seq(12,26,1 )),
schedule = as.factor(c(rep(1, 5,), rep(2, 3), rep(3, 6),
rep (1, 3), rep (2, 2), rep(3, 5),
rep(1,8), rep(2, 5), rep(1,3), rep(3, 12))),
status = c(rep("", 9), "Mort", rep("", 41), "Mort"))
Code to get the output table I am interested in:
library("data.table")
library(plyr)
library(dplyr)
df<-as.data.table(df)
z <- df[, unique(id)]
################
value_change_first <- function(x,a) { for(i in 1:length(x[,schedule])) {
ifelse(x[a,schedule] == x[a+1,schedule],
x <- x[-(a+1)],
a <- a+1)}
return(x)
}
value_change_second <- function(x,a) {
for(i in 1:length(x[,schedule])) {
ifelse(x[a,schedule] == x[a+1,schedule],
x <- x[-(a)],
a <- a+1)}
return(x)
}
#################
output_1 <- c()
for(i in 1:length(z)){
ids <- df[df$id==z[i],]
out<-value_change_first(ids,1)
output_1<-as.data.frame(rbind(output_1, out))}
#################
output_2 <- c()
for(i in 1:length(z)){
ids <- df[df$id==z[i],]
out<-value_change_second(ids,1)
output_2<-as.data.frame(rbind(output_2, out))}
################
output_1$End_Date <- output_2$date
output_1$End_Status <- output_2$status
names(output_1)[names(output_1)=="date"] <- "Start_Date"
output <- output_1[c(1:2, 5, 3, 6)]
From here I can use the Timeline Package to get something close to what I want:
require(timeline)
tl <- timeline(output,
label.col=names(output)[4],
text.color= NA,
group.col=names(output)[1],
start.col=names(output)[2],
end.col = names(output)[3])
tl + theme_bw() + theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
My question is how to build something similar in ggplot. Furthermore, I want to specifically add the "Mort" message at a given date by individual from the output dataframe.
I ended up getting this to work like I want:
### creating a end status column that includes mortalities and failures
output$End_Status_Date<-NA
for(i in 1:nrow(output)){
if(output$End_Status[i] == "Mort"){
output$End_Status_Date[i]=as.character(output$End_Date)[i]
}
}
for(i in 1:nrow(output)){
if(output$End_Status[i] == "Failure"){
output$End_Status_Date[i]=as.character(output$End_Date)[i]
}
}
### data structuring
output$id<-as.factor(output$id)
output$End_Status_Date<-as.numeric(output$End_Status_Date)
output$End_Status[output$End_Status == ""] <- NA
output$End_Status<-as.character(output$End_Status)
output$End_Status<-as.factor(output$End_Status)
library(ggplot2)
g2 <- ggplot() +
geom_segment(data=output, aes(x=Start_Date, xend=End_Date, y=id, yend=id, color=schedule), linetype=1, size=2) +
geom_point(data=subset(output, is.na(End_Status)==FALSE),
mapping=aes(x=End_Status_Date, y=id, shape=End_Status, fill=End_Status), size=4)+
scale_colour_manual(values=c("blue4", "chartreuse4", "darkmagenta"))+
scale_fill_manual(values=c("white", "red"))+
scale_shape_manual(values=c(21,24))+
xlab("Time")+
ylab("Individuals")+
theme_bw() + theme(panel.grid.minor = element_blank(), panel.grid.major = element_blank())
g2
You did most of the work already. The key here is just to use geom_rect and take advantage of your y-axis labels to set the ymin and ymax values.
ggplot(output, aes(xmin = Start_Date, xmax = End_Date,
ymin = as.numeric(id) - 1, ymax = as.numeric(id),
fill = schedule)) +
geom_rect() +
geom_text(aes(x = End_Date, y = id, label = End_Status))
Related
I'm trying to check the correlation of a bunch of variables and wanted to create a graph(s) of all the dependent variables on my response.
Price <- c(10,11,22,15,15)
Var1 <- c(2,3,12,5,17)
Var2 <- c(3,3,12,16,7)
Var3 <- c(2,5,2,5,18)
data <- data.frame(Var1,Var2,Var3,Price)
I was thinking something like this would work ;
variables <- c('Var1', 'Var2', 'Var3')
for (i in variables){
plot <- ggplot(data=data, aes(x = i, y=Price))+
geom_point(shape=16, color="dodgerblue")+
geom_smooth(method=lm, color='Black')
print(plot)
}
But it only prints out the response for variable 3 without any values of x.
As i in your loop is a character, you need to call it with get(i) in your ggplot:
for (i in variables){
plot <- ggplot(data=data, aes(x = get(i), y=Price))+
geom_point(shape=16, color="dodgerblue")+
geom_smooth(method=lm, color='Black')
print(plot)
}
will work.
Two alternatives to have the 3 graphs together:
alternative 1
Long format, and facet_wrap:
library(tidyr)
pivot_longer(data,paste0("Var",1:3)) %>%
ggplot(aes(value,Price))+
geom_point(shape=16, color="dodgerblue")+
geom_smooth(method=lm, color='Black')+
facet_wrap(~name)
second alternative
You could try to use the wonderful {patchwork} package also:
plot_list <- lapply(variables,function(i){
ggplot(data=data, aes(x = get(i), y=Price))+
geom_point(shape=16, color="dodgerblue")+
geom_smooth(method=lm, color='Black')+
labs(x = i)
})
library(patchwork)
wrap_plots(plot_list)
par works in low-level plotting.
par(mfrow=c(1, 3))
with(data, lapply(names(data)[1:3], \(x) {
plot(data[c(x, 'Price')]); abline(lm(Price ~ get(x)))
}))
Data:
data <- structure(list(Var1 = c(2, 3, 12, 5, 17), Var2 = c(3, 3, 12,
16, 7), Var3 = c(2, 5, 2, 5, 18), Price = c(10, 11, 22, 15, 15
)), class = "data.frame", row.names = c(NA, -5L))
Is there a way to create a function for my code below? I have multiple csv files that I'm running this exact code on, but it has been tiring using this same code over and over to do the same thing (and has made my script very long). Here is my code-
#define a function "add_peaks" to transpose peak values into summary table
add_peaks <- function(df, vec, colname) {
if(colname %in% names(df)) vec <- c(df[[colname]], vec)
new_row <- max(nrow(df), length(vec))
new_df <- df[1:new_row, ,drop = FALSE]
new_df[colname] <- c(vec, rep(NA, new_row - length(vec)))
new_df[is.na(new_df)] <- 0
rownames(new_df) <- NULL
new_df
}
#####INPUT#####
#Read in appropriate experiment number
#Remove first 2 columns
#Rename first column to "mintime" and convert to minutes
#Normalize raw fluorescence values
flowdata <- read_csv("####.csv") ####CHANGE EXP NUMBER
title <- "CONDITION HERE" ####CHANGE CONDITION"
flowdata <- flowdata[, -c(1:2)] %>%
rename(mintime = 1) %>%
transform(mintime = mintime / 60)
flowdata[,-1] <- data.frame(lapply(flowdata[,-1], function(X) X/X[1]))
#Exclude values up to 5 minutes
#Determine number of peaks per cell
#Add number of peaks per cell to summary table
flowdata_cut <- flowdata[which(flowdata$mintime>=5),]
peak_info <- lapply(flowdata_cut[,-1], findpeaks, threshold=2)
numberpeak <- unlist(lapply(peak_info, nrow))
summarypeaks <- add_peaks(summarypeaks, numberpeak, title)
#Prepare data for line graph
melted <- melt(flowdata, id.vars="mintime")
#####CREATE GRAPH#####
#Plot graph
ggplot(data=melted, aes(x=mintime, y=value, group=variable)) +
geom_line(show.legend = FALSE) +
scale_x_continuous(limits = c(3, 12), breaks = seq(3, 12, by = 3)) +
labs(y="Fluo-4 fluorescence (F/F0)", x = "Time (min)") +
ggtitle(title) +
theme_bw() +
# remove elements we don't need
theme(panel.grid = element_blank(),
panel.border = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.line = element_line(colour = "black"),
panel.background = element_blank())
#####SAVE GRAPH#####
#Save line graph as .png file
ggsave(filename = "####_Line_Graph.png", ####CHANGE EXP NUMBER
width = 8, height = 4)
Please let me know if it is possible (code is appreciated), even if it is part of it only. Obviously I am new to coding. Thank you!
Below is your code, extracted into a function that takes 2 arguments - the experiment number (exp) and the condition (cond).
my_function <- function(exp, cond) {
#Read in appropriate experiment number
#Remove first 2 columns
#Rename first column to "mintime" and convert to minutes
#Normalize raw fluorescence values
flowdata <- read_csv(paste0(exp, ".csv"))
title <- cond
flowdata <- flowdata[, -c(1:2)] %>%
rename(mintime = 1) %>%
transform(mintime = mintime / 60)
flowdata[,-1] <- data.frame(lapply(flowdata[,-1], function(X) X/X[1]))
#Exclude values up to 5 minutes
#Determine number of peaks per cell
#Add number of peaks per cell to summary table
flowdata_cut <- flowdata[which(flowdata$mintime>=5),]
peak_info <- lapply(flowdata_cut[,-1], findpeaks, threshold=2)
numberpeak <- unlist(lapply(peak_info, nrow))
summarypeaks <- add_peaks(summarypeaks, numberpeak, title)
#Prepare data for line graph
melted <- melt(flowdata, id.vars="mintime")
#####CREATE GRAPH#####
#Plot graph
ggplot(data=melted, aes(x=mintime, y=value, group=variable)) +
geom_line(show.legend = FALSE) +
scale_x_continuous(limits = c(3, 12), breaks = seq(3, 12, by = 3)) +
labs(y="Fluo-4 fluorescence (F/F0)", x = "Time (min)") +
ggtitle(title) +
theme_bw() +
# remove elements we don't need
theme(panel.grid = element_blank(),
panel.border = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
axis.line = element_line(colour = "black"),
panel.background = element_blank())
#####SAVE GRAPH#####
#Save line graph as .png file
ggsave(filename = paste0(exp, "_Line_Graph.png"), width = 8, height = 4)
# Return
return(summarypeaks)
}
If you have experiment number 005 and condition "test", call the function like so, assigning the result to replace the old value of summarypeaks:
summarypeaks <- my_function(005, "test")
I have a waterfall chart in working condition. However when the dataframe is empty it returns error. The dataframe can be empty when there is no data for the specified condition.
Below is the code I am using to plot waterfall chart. Instead of error I would like to print" The specified report does not have data"
#dataset <- data.frame(TotalHeadcount = c(-417, -12, 276, -276, 787, 14), Category = LETTERS[1:6])
dataset <- data.frame(TotalHeadcount = NA, Category = NA)[numeric(0), ]
dataset
dataset$SortedCategory <- factor(dataset$`Category`, levels = dataset$`Category`)
dataset$id <- seq_along(dataset$TotalHeadcount)
dataset$type <- ifelse(dataset$TotalHeadcount > 0, "in", "out")
dataset[dataset$SortedCategory %in% c("A", "F"), "type"] <- "net"
dataset$type <- factor(dataset$type, levels = c("out", "in", "net"))
dataset$end <- cumsum(dataset$`TotalHeadcount`)
dataset$end <- c(head(dataset$end, -1), 0)
dataset$start <- c(0, head(dataset$end, -1))
dataset$value <-dataset$`TotalHeadcount`
library(ggplot2)
strwr <- function(str) gsub(" ", "\n", str)
ggplot(dataset, aes(fill = type))+ geom_rect(aes(x = SortedCategory, xmin = id - 0.45, xmax = id + 0.45, ymin = end, ymax = start))+ scale_x_discrete("", breaks = levels(dataset$SortedCategory), labels = strwr(levels(dataset$SortedCategory)))+ theme_bw()+ theme(panel.border = element_blank(), panel.grid.major = element_blank(), axis.line = element_line(colour = "gray"))+guides(fill=FALSE)
Here I have commented the actual dataframe data which works fine. Instead of that I have added an empty dataframe and this code gives error.
Any help would be really appreciated.
Regards,
Akash
Where do you want to show the your error message? Does this work?
if(nrow(dataset) == 0) {
print("The specified report does not have data")
} else {
ggplot(dataset, ...
}
I'm trying to make a scatter plot in R with ggplot2, where the middle of the y-axis is collapsed or removed, because there is no data there. I did it in photoshop below, but is there a way to create a similar plot with ggplot?
This is the data with a continuous scale:
But I'm trying to make something like this:
Here is the code:
ggplot(data=distance_data) +
geom_point(
aes(
x = mdistance,
y = maxZ,
shape = factor(subj),
color = factor(side),
size = (cSA)
)
) +
scale_size_continuous(range = c(4, 10)) +
theme(
axis.text.x = element_text(colour = "black", size = 15),
axis.text.y = element_text(colour = "black", size = 15),
axis.title.x = element_text(colour = "black", size= 20, vjust = 0),
axis.title.y = element_text(colour = "black", size= 20),
legend.position = "none"
) +
ylab("Z-score") +
xlab("Distance")
You could do this by defining a coordinate transformation. A standard example are logarithmic coordinates, which can be achieved in ggplot by using scale_y_log10().
But you can also define custom transformation functions by supplying the trans argument to scale_y_continuous() (and similarly for scale_x_continuous()). To this end, you use the function trans_new() from the scales package. It takes as arguments the transformation function and its inverse.
I discuss first a special solution for the OP's example and then also show how this can be generalised.
OP's example
The OP wants to shrink the interval between -2 and 2. The following defines a function (and its inverse) that shrinks this interval by a factor 4:
library(scales)
trans <- function(x) {
ifelse(x > 2, x - 1.5, ifelse(x < -2, x + 1.5, x/4))
}
inv <- function(x) {
ifelse(x > 0.5, x + 1.5, ifelse(x < -0.5, x - 1.5, x*4))
}
my_trans <- trans_new("my_trans", trans, inv)
This defines the transformation. To see it in action, I define some sample data:
x_val <- 0:250
y_val <- c(-6:-2, 2:6)
set.seed(1234)
data <- data.frame(x = sample(x_val, 30, replace = TRUE),
y = sample(y_val, 30, replace = TRUE))
I first plot it without transformation:
p <- ggplot(data, aes(x, y)) + geom_point()
p + scale_y_continuous(breaks = seq(-6, 6, by = 2))
Now I use scale_y_continuous() with the transformation:
p + scale_y_continuous(trans = my_trans,
breaks = seq(-6, 6, by = 2))
If you want another transformation, you have to change the definition of trans() and inv() and run trans_new() again. You have to make sure that inv() is indeed the inverse of inv(). I checked this as follows:
x <- runif(100, -100, 100)
identical(x, trans(inv(x)))
## [1] TRUE
General solution
The function below defines a transformation where you can choose the lower and upper end of the region to be squished, as well as the factor to be used. It directly returns the trans object that can be used inside scale_y_continuous:
library(scales)
squish_trans <- function(from, to, factor) {
trans <- function(x) {
if (any(is.na(x))) return(x)
# get indices for the relevant regions
isq <- x > from & x < to
ito <- x >= to
# apply transformation
x[isq] <- from + (x[isq] - from)/factor
x[ito] <- from + (to - from)/factor + (x[ito] - to)
return(x)
}
inv <- function(x) {
if (any(is.na(x))) return(x)
# get indices for the relevant regions
isq <- x > from & x < from + (to - from)/factor
ito <- x >= from + (to - from)/factor
# apply transformation
x[isq] <- from + (x[isq] - from) * factor
x[ito] <- to + (x[ito] - (from + (to - from)/factor))
return(x)
}
# return the transformation
return(trans_new("squished", trans, inv))
}
The first line in trans() and inv() handles the case when the transformation is called with x = c(NA, NA). (It seems that this did not happen with the version of ggplot2 when I originally wrote this question. Unfortunately, I don't know with which version this startet.)
This function can now be used to conveniently redo the plot from the first section:
p + scale_y_continuous(trans = squish_trans(-2, 2, 4),
breaks = seq(-6, 6, by = 2))
The following example shows that you can squish the scale at an arbitrary position and that this also works for other geoms than points:
df <- data.frame(class = LETTERS[1:4],
val = c(1, 2, 101, 102))
ggplot(df, aes(x = class, y = val)) + geom_bar(stat = "identity") +
scale_y_continuous(trans = squish_trans(3, 100, 50),
breaks = c(0, 1, 2, 3, 50, 100, 101, 102))
Let me close by stressing what other already mentioned in comments: this kind of plot could be misleading and should be used with care!
This question is unlikely to help any future visitors; it is only relevant to a small geographic area, a specific moment in time, or an extraordinarily narrow situation that is not generally applicable to the worldwide audience of the internet. For help making this question more broadly applicable, visit the help center.
Closed 9 years ago.
I'm running a loop to get, at each sub setting of my data set, a map and apply a given palette (and respective legend) accordingly.
People tend to dislike the use of for() loops and maximize vectorization of their approaches. I don't know the best way to vectorize processes with this particular data set.
In this particular case, I'm handling a relatively large data set (distribution species Atlas) that is particularly complex since different methodologies were used and different options must be passed for each species, considering a particular season, different set of observations, etc.
Species may be present at one season and missed into another (They may be a breeder, a resident or a migrant). Maps should be created for all cases (seasons), empty when absent. Additional data (besides those from field work) may be available and used.
Map Legend must accommodate all variations, besides presenting variable in interest (abundances) in a custom discrete scale.
By running a loop I feel (to my limited expertise) I can more easily retain and control the several needed objects, while stepping into the flux I created to produce the pieces of interest and finally create sets of species distributions maps.
My Problem is that I'm storing each resulting ggplot in a list() object. Each species at each season will be stored in a list. The
issue I'm facing is related to scale_fill_manual when used
inside a loop.
The behavior is strange since I get the maps done but with colors applied only to the last ggplot output. Nonetheless all values still being correctly identified in the legend.
to exemplify:
Packages
if (!require(ggplot2)) install.packages("ggplot2",
repos = "http://cran.r-project.org"); library(ggplot2)
if (!require(grid)) install.packages("grid",
repos = "http://cran.r-project.org"); library(grid)
if (!require(RColorBrewer)) install.packages("RColorBrewer",
repos = "http://cran.r-project.org"); library(RColorBrewer)
if (!require(reshape)) install.packages("reshape",
repos = "http://cran.r-project.org"); library(reshape)
A simple example first
#Create a list of colors to be used with scale_manual
palette.l <- list()
palette.l[[1]] <- c('red', 'blue', 'green')
palette.l[[2]] <- c('pink', 'blue', 'yellow')
# Store each ggplot in a list object
plot.l <- list()
#Loop it
for(i in 1:2){
plot.l[[i]] <- qplot(mpg, wt, data = mtcars, colour = factor(cyl)) +
scale_colour_manual(values = palette.l[[i]])
}
In my session plot.l[1] will be painted with colors from palette.l[2].
My particular case
Functions
Arrange Plots
ArrangeGraph <- function(..., nrow=NULL, ncol=NULL, as.table=FALSE) {
dots <- list(...)
n <- length(dots)
if(is.null(nrow) & is.null(ncol)) { nrow = floor(n/2) ; ncol = ceiling(n/nrow)}
if(is.null(nrow)) { nrow = ceiling(n/ncol)}
if(is.null(ncol)) { ncol = ceiling(n/nrow)}
## NOTE see n2mfrow in grDevices for possible alternative
grid.newpage()
pushViewport(viewport(layout=grid.layout(nrow,ncol)))
ii.p <- 1
for(ii.row in seq(1, nrow)) {
ii.table.row <- ii.row
if(as.table) {ii.table.row <- nrow - ii.table.row + 1}
for(ii.col in seq(1, ncol)) {
ii.table <- ii.p
if(ii.p > n) break
print(dots[[ii.table]], vp=VPortLayout(ii.table.row, ii.col))
ii.p <- ii.p + 1
}
}
}
ViewPort
VPortLayout <- function(x, y) viewport(layout.pos.row=x, layout.pos.col=y)
Species data sets
bd.aves.1 <- structure(list(quad = c("K113", "K114", "K114", "K114", "K114",...
due to limited body character number limit, please download entire code from
https://docs.google.com/open?id=0BxSZDr4eTnb9R09iSndzZjBMS28
Species list
list.esp.1 <- c("Sylv mela", "Saxi rube","Ocea leuc")#
# download from the above link
Some taxonomy and other data
txcon.1 <- structure(list(id = c(156L, 359L, 387L), grupo = c("Aves", "Aves",#
# download from the above link
Seasons
kSeason.1 <- c("Inverno", "Primavera", "Outono")
A Sample Grid
grid500.df.1 <- structure(list(id = c("K113", "K113", "K113", "K113", "K113",#...
# download from the above link
Additional Mapping elements
Shoreline
coastline.df.1 <- structure(list(long = c(182554.963670234, 180518, 178865.39,#...
# download from the above link
Labels placement adjustments
kFacx1 <- c(9000, -13000, -10000, -12000)
The R Code
for(i in listsp.1) { # LOOP 1 - Species
# Set up objects
sist.i <- list() # Sistematic observations
nsist.i <- list() # Non-Sistematic observations
breaks.nind.1 <- list() # Breaks on abundances
## Grid and merged dataframe
spij.1 <- list() # Stores a dataframe for sp i at season j
## Palette build
classes.1 <- list()
cllevels.1 <- list()
palette.nind.1 <- list() # Color palette
## Maps
grid500ij.1 <- list() # Grid for species i at season j
map.dist.ij.1 <- NULL
for(j in 1:length(kSeason.1)) { # LOOP 2 - Seasons
# j assume each season: Inverno, Primavera, Outono
# Sistematic occurences ===================================================
sist.i.tmp <- nrow(subset(bd.aves.1, esp == i & cod_tipo %in% sistematica &
periodo == kSeason.1[j]))
if (sist.i.tmp!= 0) { # There is sistematic entries, Then:
sist.i[[j]]<- ddply(subset(bd.aves.1,
esp == i & cod_tipo %in% sistematica &
periodo == kSeason.1[j]),
.(periodo, quad), summarise, nind = sum(n_ind),
codnid = max(cod_nidi))
} else { # No Sistematic entries, Then:
sist.i[[j]] <- data.frame('quad' = NA, 'periodo' = NA, 'nind' = NA,
'codnid' = NA, stringsAsFactors = F)
}
# Additional Entries (RS1) e other non-sistematic entries (biblio) =======
nsist.tmp.i = nrow(subset(bd.aves.1, esp == i & !cod_tipo %in% sistematica &
periodo == kSeason.1[j]))
if (nsist.tmp.i != 0) { # RS1 and biblio entries, Then:
nsist.i[[j]] <- subset(bd.aves.1,
esp == i & !cod_tipo %in% sistematica &
periodo == kSeason.1[j] &
!quad %in% if (nrow(sist.i[[j]]) != 0) {
subset(sist.i[[j]],
select = quad)$quad
} else NA,
select = c(quad, periodo, cod_tipo, cod_nidi)
)
names(nsist.i[[j]])[4] <- 'codnid'
} else { # No RS1 and biblio entries, Then:
nsist.i[[j]] = data.frame('quad' = NA, 'periodo' = NA, 'cod_tipo' = NA,
'codnid' = NA, stringsAsFactors = F)
}
# Quantile breaks =========================================================
if (!is.na(sist.i[[j]]$nind[1])) {
breaks.nind.1[[j]] <- c(0,
unique(
ceiling(
quantile(unique(
subset(sist.i[[j]], is.na(nind) == F)$nind),
q = seq(0, 1, by = 0.25)))))
} else {
breaks.nind.1[[j]] <- 0
}
# =========================================================================
# Build Species dataframe and merge to grid
# =========================================================================
if (!is.na(sist.i[[j]]$nind[1])) { # There are Sistematic entries, Then:
spij.1[[j]] <- merge(unique(subset(grid500df.1, select = id)),
sist.i[[j]],
by.x = 'id', by.y = 'quad', all.x = T)
# Adjust abundances when equals to NA ===================================
spij.1[[j]]$nind[is.na(spij.1[[j]]$nind) == T] <- 0
# Break abundances to create discrete variable ==========================
spij.1[[j]]$cln <- if (length(breaks.nind.1[[j]]) > 2) {
cut(spij.1[[j]]$nind, breaks = breaks.nind.1[[j]],
include.lowest = T, right = F)
} else {
cut2(spij.1[[j]]$nind, g = 2)
}
# Variable Abundance ====================================================
classes.1[[j]] = nlevels(spij.1[[j]]$cln)
cllevels.1[[j]] = levels(spij.1[[j]]$cln)
# Color Palette for abundances - isolated Zero class (color #FFFFFF) ====
if (length(breaks.nind.1[[j]]) > 2) {
palette.nind.1[[paste(kSeason.1[j])]] = c("#FFFFFF", brewer.pal(length(
cllevels.1[[j]]) - 1, "YlOrRd"))
} else {
palette.nind.1[[paste(kSeason.1[j])]] = c(
"#FFFFFF", brewer.pal(3, "YlOrRd"))[1:classes.1[[j]]]
}
names(palette.nind.1[[paste(kSeason.1[j])]])[1 : length(
palette.nind.1[[paste(kSeason.1[j])]])] <- cllevels.1[[j]]
# Add RS1 and bilbio values to palette ==================================
palette.nind.1[[paste(kSeason.1[j])]][length(
palette.nind.1[[paste(kSeason.1[j])]]) + 1] <- '#CCC5AF'
names(palette.nind.1[[paste(kSeason.1[j])]])[length(
palette.nind.1[[paste(kSeason.1[j])]])] <- 'Suplementar'
palette.nind.1[[paste(kSeason.1[j])]][length(
palette.nind.1[[paste(kSeason.1[j])]]) + 1] <- '#ADCCD7'
names(palette.nind.1[[paste(kSeason.1[j])]])[length(
palette.nind.1[[paste(kSeason.1[j])]])] <- 'Bibliografia'
# Merge species i dataframe to grid map =================================
grid500ij.1[[j]] <- subset(grid500df.1, select = c(id, long, lat, order))
grid500ij.1[[j]]$cln = merge(grid500ij.1[[j]],
spij.1[[j]],
by.x = 'id', by.y = 'id', all.x = T)$cln
# Adjust factor levels of cln variable - Non-Sistematic data ============
levels(grid500ij.1[[j]]$cln) <- c(levels(grid500ij.1[[j]]$cln), 'Suplementar',
'Bibliografia')
if (!is.na(nsist.i[[j]]$quad[1])) {
grid500ij.1[[j]]$cln[grid500ij.1[[j]]$id %in% subset(
nsist.i[[j]], cod_tipo == 'RS1', select = quad)$quad] <- 'Suplementar'
grid500ij.1[[j]]$cln[grid500ij.1[[j]]$id %in% subset(
nsist.i[[j]], cod_tipo == 'biblio', select = quad)$quad] <- 'Bibliografia'
}
} else { # No Sistematic entries, Then:
if (!is.na(nsist.i[[j]]$quad[1])) { # RS1 or Biblio entries, Then:
grid500ij.1[[j]] <- grid500df
grid500ij.1[[j]]$cln <- '0'
grid500ij.1[[j]]$cln <- factor(grid500ij.1[[j]]$cln)
levels(grid500ij.1[[j]]$cln) <- c(levels(grid500ij.1[[j]]$cln),
'Suplementar', 'Bibliografia')
grid500ij.1[[j]]$cln[grid500ij.1[[j]]$id %in% subset(
nsist.i[[j]], cod_tipo == 'RS1',
select = quad)$quad] <- 'Suplementar'
grid500ij.1[[j]]$cln[grid500ij.1[[j]]$id %in% subset(
nsist.i[[j]],cod_tipo == 'biblio',
select = quad)$quad] <- 'Bibliografia'
} else { # No entries, Then:
grid500ij.1[[j]] <- grid500df
grid500ij.1[[j]]$cln <- '0'
grid500ij.1[[j]]$cln <- factor(grid500ij.1[[j]]$cln)
levels(grid500ij.1[[j]]$cln) <- c(levels(grid500ij.1[[j]]$cln),
'Suplementar', 'Bibliografia')
}
} # End of Species dataframe build
# Distribution Map for species i at season j =============================
if (!is.na(sist.i[[j]]$nind[1])) { # There is sistematic entries, Then:
map.dist.ij.1[[paste(kSeason.1[j])]] <- ggplot(grid500ij.1[[j]],
aes(x = long, y = lat)) +
geom_polygon(aes(group = id, fill = cln), colour = 'grey80') +
coord_equal() +
scale_x_continuous(limits = c(100000, 180000)) +
scale_y_continuous(limits = c(-4000, 50000)) +
scale_fill_manual(
name = paste("LEGEND",
'\nSeason: ', kSeason.1[j],
'\n% of Occupied Cells : ',
sprintf("%.1f%%", (length(unique(
grid500ij.1[[j]]$id[grid500ij.1[[j]]$cln != levels(
grid500ij.1[[j]]$cln)[1]]))/12)*100), # percent
sep = ""
),
# Set Limits
limits = names(palette.nind.1[[j]])[2:length(names(palette.nind.1[[j]]))],
values = palette.nind.1[[j]][2:length(names(palette.nind.1[[j]]))],
drop = F) +
opts(
panel.background = theme_rect(),
panel.grid.major = theme_blank(),
panel.grid.minor = theme_blank(),
axis.ticks = theme_blank(),
title = txcon.1$especie[txcon.1$esp == i],
plot.title = theme_text(size = 10, face = 'italic'),
axis.text.x = theme_blank(),
axis.text.y = theme_blank(),
axis.title.x = theme_blank(),
axis.title.y = theme_blank(),
legend.title = theme_text(hjust = 0,size = 10.5),
legend.text = theme_text(hjust = -0.2, size = 10.5)
) +
# Shoreline
geom_path(inherit.aes = F, aes(x = long, y = lat),
data = coastline.df.1, colour = "#997744") +
# Add localities
geom_point(inherit.aes = F, aes(x = x, y = y), colour = 'grey20',
data = localidades, size = 2) +
# Add labels
geom_text(inherit.aes = F, aes(x = x, y = y, label = c('Burgau',
'Sagres')),
colour = "black",
data = data.frame(x = c(142817 + kFacx1[1], 127337 + kFacx1[4]),
y = c(11886, 3962), size = 3))
} else { # NO sistematic entries,then:
map.dist.ij.1[[paste(kSeason.1[j])]] <- ggplot(grid500ij.1[[j]],
aes(x = long, y = lat)) +
geom_polygon(aes.inherit = F, aes(group = id, fill = cln),
colour = 'grey80') +
#scale_color_manual(values = kCorLimiteGrid) +
coord_equal() +
scale_x_continuous(limits = c(100000, 40000)) +
scale_y_continuous(limits = c(-4000, 180000)) +
scale_fill_manual(
name = paste('LEGENDA',
'\nSeason: ', kSeason.1[j],
'\n% of Occupied Cells :',
sprintf("%.1f%%", (length(unique(
grid500ij.1[[j]]$id[grid500ij.1[[j]]$cln != levels(
grid500ij.1[[j]]$cln)[1]]))/12 * 100)), # percent
sep = ''),
limits = names(kPaletaNsis)[2:length(names(kPaletaNsis))],
values = kPaletaNsis[2:length(names(kPaletaNsis))],
drop = F) +
opts(
panel.background = theme_rect(),
panel.grid.major = theme_blank(),
panel.grid.minor = theme_blank(),
title = txcon.1$especie[txcon.1$esp == i],
plot.title = theme_text(size = 10, face = 'italic'),
axis.ticks = theme_blank(),
axis.text.x = theme_blank(),
axis.text.y = theme_blank(),
axis.title.x = theme_blank(),
axis.title.y = theme_blank(),
legend.title = theme_text(hjust = 0,size = 10.5),
legend.text = theme_text(hjust = -0.2, size = 10.5)
) +
# Add Shoreline
geom_path(inherit.aes = F, data = coastline.df.1,
aes(x = long, y = lat),
colour = "#997744") +
# Add Localities
geom_point(inherit.aes = F, aes(x = x, y = y),
colour = 'grey20',
data = localidades, size = 2) +
# Add labels
geom_text(inherit.aes = F, aes(x = x, y = y,
label = c('Burgau', 'Sagres')),
colour = "black",
data = data.frame(x = c(142817 + kFacx1[1],
127337 + kFacx1[4],),
y = c(11886, 3962)),
size = 3)
} # End of Distribution map building for esp i and j seasons
} # Fim do LOOP 2: j Estacoes
# Print Maps
png(file = paste('panel_species',i,'.png', sep = ''), res = 96,
width = 800, height = 800)
ArrangeGraph(map.dist.ij.1[[paste(kSeason.1[3])]],
map.dist.ij.1[[paste(kSeason.1[2])]],
map.dist.ij.1[[paste(kSeason.1[1])]],
ncol = 2, nrow = 2)
dev.off()
graphics.off()
} # End of LOOP 1
map.dist.ij.1[[paste(kSeason.1[3])]] is the only with color palette applied to polygons, but the legend items is well defined for each j map.
Output using R Code
As we see, Legends are OK but not colored.
Hope not missing anything. Sorry for some lost Portuguese terminology.
Honestly, I have not looked much at your code for your specific problem--a bit too much to wade through!--but for your demo example, adding print(plot.l[[i]]) in your loop.
#Create a list of colors to be used with scale_manual
palette.l <- list()
palette.l[[1]] <- c('red', 'blue', 'green')
palette.l[[2]] <- c('pink', 'blue', 'yellow')
# Store each ggplot in a list object
plot.l <- list()
# Loop it
for(i in 1:2) {
plot.l[[i]] <- qplot(mpg, wt, data = mtcars, colour = factor(cyl)) +
scale_colour_manual(values = palette.l[[i]])
print(plot.l[[i]]) ### Added to your loop
}
In the case of your minimal example, though, this also works (without first having to create an empty list to store your plots) and I think it at least looks a lot cleaner. I'm not sure if something similar can be adapted to suit your larger scenario.
#Create a list of colors to be used with scale_manual
palette.l <- list(c('red', 'blue', 'green'),
c('pink', 'blue', 'yellow'))
p <- qplot(mpg, wt, data = mtcars, colour = factor(cyl))
# Use lapply and "force" to get your plots in a list
plot.l <- lapply(palette.l,
function(x) {
force(x)
p + scale_color_manual(values = x)
})