Related
Willing to plot multiple barplots on a map, I was able to use this solution below, converting ggplots into images with r magick and putting them on map - also an image.
Any way to plot multiple barplots on a map?
I want to create multiple maps each time, having 10 scenarios, with each 12 barplots to put on the map. I tried implementing a loop, but the image_graph function from magick doesn't work within.
library(ggmap)
library(maps)
library(ggplot2)
library(magick)
mp <- NULL
mapWorld <- borders("world", colour="gray70", fill="gray70")
fig <- image_graph(width = 850, height = 550, res = 96)
ggplot() + mapWorld
dev.off()
df <- data.frame(region = c('France','UK'), name =
c('A','B','C','A','B','C'), value1 = c(20,15,15,10,8,8), value2 =
c(10,15,20,5,8,10) , value3 = c(5,15,10,3,8,5) )
scenarios = c('value1', 'value2', 'value3')
for (scenario in scenarios ) {
for (reg in unique(df$region) ) {
df_reg = df[ (df$region == reg), ]
bp <- ggplot(df_reg, aes_string(x = "region", y = scenario, fill = "name")) +
geom_bar(stat = 'identity') +
theme_bw() +
theme(legend.position = "none", axis.title.x = element_blank(), axis.title.y = element_blank())
barfig <- image_graph(width = 100, height = 75, res = 72)
bp
dev.off()
barplotname = paste0('barfig_',reg )
assign(barplotname, barfig)
}
final <- image_composite(fig, barfig_France, offset = "+75+150")
final <- image_composite(final, barfig_UK, offset = "+325+125")
final
filename = paste0('map_', scenario , ".png")
image_write(final, path = filename, format = "png" )
}
It works properly if I decompose the loop manually as below, and I can't find why it doesn't in the loop. I didn't find info in the magick documentation or examples of uses of the image_graph function within loops.
for (reg in unique(df$region) ) {
df_reg = df[ (df$region == reg), ]
bp <- ggplot(df_reg, aes_string(x = "region", y = "value1")) + geom_bar(stat = 'identity', aes(fill = name) ) + #trying in one
theme_bw() +
theme(legend.position = "none", axis.title.x = element_blank(), axis.title.y = element_blank())
barplotname = paste0('bp_',reg )
assign(barplotname, bp)
}
barfig_France <- image_graph(width = 100, height = 75, res = 72)
bp_France
dev.off()
barfig_UK <- image_graph(width = 100, height = 75, res = 72)
bp_UK
dev.off()
final <- image_composite(fig, barfig_France, offset = "+75+150")
final <- image_composite(final, barfig_UK, offset = "+325+125")
final
If I try to integrate this block in the "for (scenarios... )" loop, issue remains the same, I fail to convert my plots into images
Found a basic workaround consisting in saving barplots then importing them again using image_read
for (scenario in scenarios ) {
for (reg in unique(df$region) ) {
df_reg = df[ (df$region == reg), ]
bp <- ggplot(df_reg, aes_string(x = "region", y = scenario)) + geom_bar(stat = 'identity', aes(fill = name) ) + #trying in one
theme_bw() +
theme(legend.position = "none", axis.title.x = element_blank(), axis.title.y = element_blank())
barplotname = paste0('barfig_',reg, '.svg')
ggsave(barplotname, bp, width = 1.2, height = 1, dpi = 72)
plotname = paste0('barfig_', reg)
img = image_read_svg(barplotname)
assign(plotname ,img)
}
final <- image_composite(fig, barfig_France, offset = "+75+150")
final <- image_composite(final, barfig_UK, offset = "+325+125")
final
filename = paste0('map_', scenario , ".png")
image_write(final, path = filename, format = "png" )
}
I think you need to print() the ggplot object inside the loop rather than just calling it, i.e.
barfig <- image_graph(width = 100, height = 75, res = 72)
print(bp) # not bp
dev.off()
[enter image description here][1]I am trying to create a lowry plot in R but am having difficulty debugging the errors returned. I am using the following code to create the plot:
library(ggplot2)
library(reshape)
m_xylene_data <- data.frame(
Parameter = c(
"BW", "CRE", "DS", "KM", "MPY", "Pba", "Pfaa",
"Plia", "Prpda", "Pspda", "QCC", "QfaC", "QliC",
"QPC", "QspdC", "Rurine", "Vfac", "VliC", "Vmax"),
"Main Effect" = c(
1.03E-01, 9.91E-02, 9.18E-07, 3.42E-02, 9.27E-3, 2.82E-2, 2.58E-05,
1.37E-05, 5.73E-4, 2.76E-3, 6.77E-3, 8.67E-05, 1.30E-02,
1.19E-01, 4.75E-04, 5.25E-01, 2.07E-04, 1.73E-03, 1.08E-03),
Interaction = c(
1.49E-02, 1.43E-02, 1.25E-04, 6.84E-03, 3.25E-03, 7.67E-03, 8.34E-05,
1.17E-04, 2.04E-04, 7.64E-04, 2.84E-03, 8.72E-05, 2.37E-03,
2.61E-02, 6.68E-04, 4.57E-02, 1.32E-04, 6.96E-04, 6.55E-04
)
)
fortify_lowry_data <- function(data,
param_var = "Parameter",
main_var = "Main.Effect",
inter_var = "Interaction")
{
#Convert wide to long format
mdata <- melt(data, id.vars = param_var)
#Order columns by main effect and reorder parameter levels
o <- order(data[, main_var], decreasing = TRUE)
data <- data[o, ]
data[, param_var] <- factor(
data[, param_var], levels = data[, param_var]
)
#Force main effect, interaction to be numeric
data[, main_var] <- as.numeric(data[, main_var])
data[, inter_var] <- as.numeric(data[, inter_var])
#total effect is main effect + interaction
data$.total.effect <- rowSums(data[, c(main_var, inter_var)])
#Get cumulative totals for the ribbon
data$.cumulative.main.effect <- cumsum(data[, main_var])
data$.cumulative.total.effect <- cumsum(data$.total.effect)
#A quirk of ggplot2 means we need x coords of bars
data$.numeric.param <- as.numeric(data[, param_var])
#The other upper bound
#.maximum = 1 - main effects not included
data$.maximum <- c(1 - rev(cumsum(rev(data[, main_var])))[-1], 1)
data$.valid.ymax <- with(data,
pmin(.maximum, .cumulative.total.effect)
)
mdata[, param_var] <- factor(
mdata[, param_var], levels = data[, param_var]
)
list(data = data, mdata = mdata)
}
lowry_plot <- function(data,
param_var = "Parameter",
main_var = "Main.Effect",
inter_var = "Interaction",
x_lab = "Parameters",
y_lab = "Total Effects (= Main Effects + Interactions)",
ribbon_alpha = 0.5,
x_text_angle = 25)
{
#Fortify data and dump contents into plot function environment
data_list <- fortify_lowry_data(data, param_var, main_var, inter_var)
list2env(data_list, envir = sys.frame(sys.nframe()))
p <- ggplot(data) +
geom_bar(aes_string(x = param_var, y = "value", fill = "variable"),
data = mdata) +
geom_ribbon(
aes(x = .numeric.param, ymin = .cumulative.main.effect, ymax =
.valid.ymax),
data = data,
alpha = ribbon_alpha) +
xlab(x_lab) +
ylab(y_lab) +
scale_y_continuous(labels = "percent") +
theme(axis.text.x = text(angle = x_text_angle, hjust = 1)) +
scale_fill_grey(end = 0.5) +
theme(legend.position = "top",
legend.title =blank(),
legend.direction = "horizontal"
)
p
}
m_xylene_lowry <- lowry_plot(m_xylene_data)
When I run the code, it is giving me the following error:
Error: argument "x" is missing, with no default
It is not specific enough for me to know what the issue is. What is causing the error to be displayed and how can I make error statements more verbose?
Lowry PLOT
It seems that you have more than one faulty element in your code than just the error it throws. In my experience it always helps to first check whether the code works as expected before putting it into a function. The plotting-part below should work:
p <- ggplot(data) + # no need to give data here, if you overwrite it anyway blow, but does not affect outcome...
# geom_bar does the counting but does not take y-value. Use geom_col:
geom_col(aes_string(x = param_var, y = "value", fill = "variable"),
data = mdata,
position = position_stack(reverse = TRUE)) +
geom_ribbon(
aes(x = .numeric.param, ymin = .cumulative.main.effect, ymax =
.valid.ymax),
data = data,
alpha = ribbon_alpha) +
xlab(x_lab) +
ylab(y_lab) +
# use scales::percent_format():
scale_y_continuous(labels = scales::percent_format()) +
# text is not an element you can use here, use element_text():
theme(axis.text.x = element_text(angle = x_text_angle, hjust = 1)) +
scale_fill_grey(end = 0.5) +
# use element_blank(), not just blank()
theme(legend.position = "top",
legend.title = element_blank(),
legend.direction = "horizontal"
)
This at least plots something, but I'm not sure whether it is what you expect it to do. It would help if you could show the desired output.
Edit:
Added position = position_stack(reverse = TRUE) to order according to sample plot.
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))
From a data frame I want to plot a pie chart for five categories with their percentages as labels in the same graph in order from highest to lowest, going clockwise.
My code is:
League<-c("A","B","A","C","D","E","A","E","D","A","D")
data<-data.frame(League) # I have more variables
p<-ggplot(data,aes(x="",fill=League))
p<-p+geom_bar(width=1)
p<-p+coord_polar(theta="y")
p<-p+geom_text(data,aes(y=cumsum(sort(table(data)))-0.5*sort(table(data)),label=paste(as.character(round(sort(table(data))/sum(table(data)),2)),rep("%",5),sep="")))
p
I use
cumsum(sort(table(data)))-0.5*sort(table(data))
to place the label in the corresponding portion and
label=paste(as.character(round(sort(table(data))/sum(table(data)),2)),rep("%",5),sep="")
for the labels which is the percentages.
I get the following output:
Error: ggplot2 doesn't know how to deal with data of class uneval
I've preserved most of your code. I found this pretty easy to debug by leaving out the coord_polar... easier to see what's going on as a bar graph.
The main thing was to reorder the factor from highest to lowest to get the plotting order correct, then just playing with the label positions to get them right. I also simplified your code for the labels (you don't need the as.character or the rep, and paste0 is a shortcut for sep = "".)
League<-c("A","B","A","C","D","E","A","E","D","A","D")
data<-data.frame(League) # I have more variables
data$League <- reorder(data$League, X = data$League, FUN = function(x) -length(x))
at <- nrow(data) - as.numeric(cumsum(sort(table(data)))-0.5*sort(table(data)))
label=paste0(round(sort(table(data))/sum(table(data)),2) * 100,"%")
p <- ggplot(data,aes(x="", fill = League,fill=League)) +
geom_bar(width = 1) +
coord_polar(theta="y") +
annotate(geom = "text", y = at, x = 1, label = label)
p
The at calculation is finding the centers of the wedges. (It's easier to think of them as the centers of bars in a stacked bar plot, just run the above plot without the coord_polar line to see.) The at calculation can be broken out as follows:
table(data) is the number of rows in each group, and sort(table(data)) puts them in the order they'll be plotted. Taking the cumsum() of that gives us the edges of each bar when stacked on top of each other, and multiplying by 0.5 gives us the half the heights of each bar in the stack (or half the widths of the wedges of the pie).
as.numeric() simply ensures we have a numeric vector rather than an object of class table.
Subtracting the half-widths from the cumulative heights gives the centers each bar when stacked up. But ggplot will stack the bars with the biggest on the bottom, whereas all our sort()ing puts the smallest first, so we need to do nrow - everything because what we've actually calculate are the label positions relative to the top of the bar, not the bottom. (And, with the original disaggregated data, nrow() is the total number of rows hence the total height of the bar.)
Preface: I did not make pie charts of my own free will.
Here's a modification of the ggpie function that includes percentages:
library(ggplot2)
library(dplyr)
#
# df$main should contain observations of interest
# df$condition can optionally be used to facet wrap
#
# labels should be a character vector of same length as group_by(df, main) or
# group_by(df, condition, main) if facet wrapping
#
pie_chart <- function(df, main, labels = NULL, condition = NULL) {
# convert the data into percentages. group by conditional variable if needed
df <- group_by_(df, .dots = c(condition, main)) %>%
summarize(counts = n()) %>%
mutate(perc = counts / sum(counts)) %>%
arrange(desc(perc)) %>%
mutate(label_pos = cumsum(perc) - perc / 2,
perc_text = paste0(round(perc * 100), "%"))
# reorder the category factor levels to order the legend
df[[main]] <- factor(df[[main]], levels = unique(df[[main]]))
# if labels haven't been specified, use what's already there
if (is.null(labels)) labels <- as.character(df[[main]])
p <- ggplot(data = df, aes_string(x = factor(1), y = "perc", fill = main)) +
# make stacked bar chart with black border
geom_bar(stat = "identity", color = "black", width = 1) +
# add the percents to the interior of the chart
geom_text(aes(x = 1.25, y = label_pos, label = perc_text), size = 4) +
# add the category labels to the chart
# increase x / play with label strings if labels aren't pretty
geom_text(aes(x = 1.82, y = label_pos, label = labels), size = 4) +
# convert to polar coordinates
coord_polar(theta = "y") +
# formatting
scale_y_continuous(breaks = NULL) +
scale_fill_discrete(name = "", labels = unique(labels)) +
theme(text = element_text(size = 22),
axis.ticks = element_blank(),
axis.text = element_blank(),
axis.title = element_blank())
# facet wrap if that's happening
if (!is.null(condition)) p <- p + facet_wrap(condition)
return(p)
}
Example:
# sample data
resps <- c("A", "A", "A", "F", "C", "C", "D", "D", "E")
cond <- c(rep("cat A", 5), rep("cat B", 4))
example <- data.frame(resps, cond)
Just like a typical ggplot call:
ex_labs <- c("alpha", "charlie", "delta", "echo", "foxtrot")
pie_chart(example, main = "resps", labels = ex_labs) +
labs(title = "unfacetted example")
ex_labs2 <- c("alpha", "charlie", "foxtrot", "delta", "charlie", "echo")
pie_chart(example, main = "resps", labels = ex_labs2, condition = "cond") +
labs(title = "facetted example")
It worked on all included function greatly inspired from here
ggpie <- function (data)
{
# prepare name
deparse( substitute(data) ) -> name ;
# prepare percents for legend
table( factor(data) ) -> tmp.count1
prop.table( tmp.count1 ) * 100 -> tmp.percent1 ;
paste( tmp.percent1, " %", sep = "" ) -> tmp.percent2 ;
as.vector(tmp.count1) -> tmp.count1 ;
# find breaks for legend
rev( tmp.count1 ) -> tmp.count2 ;
rev( cumsum( tmp.count2 ) - (tmp.count2 / 2) ) -> tmp.breaks1 ;
# prepare data
data.frame( vector1 = tmp.count1, names1 = names(tmp.percent1) ) -> tmp.df1 ;
# plot data
tmp.graph1 <- ggplot(tmp.df1, aes(x = 1, y = vector1, fill = names1 ) ) +
geom_bar(stat = "identity", color = "black" ) +
guides( fill = guide_legend(override.aes = list( colour = NA ) ) ) +
coord_polar( theta = "y" ) +
theme(axis.ticks = element_blank(),
axis.text.y = element_blank(),
axis.text.x = element_text( colour = "black"),
axis.title = element_blank(),
plot.title = element_text( hjust = 0.5, vjust = 0.5) ) +
scale_y_continuous( breaks = tmp.breaks1, labels = tmp.percent2 ) +
ggtitle( name ) +
scale_fill_grey( name = "") ;
return( tmp.graph1 )
} ;
An example :
sample( LETTERS[1:6], 200, replace = TRUE) -> vector1 ;
ggpie(vector1)
Output
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)
})