データセットの各サブ設定でマップを取得し、それに応じて特定のパレット (およびそれぞれの凡例) を適用するループを実行しています。
人々は for() ループの使用を嫌い、アプローチのベクトル化を最大化する傾向があります。この特定のデータ セットを使用してプロセスをベクトル化する最善の方法がわかりません。
この特定のケースでは、特定の季節やさまざまな観測セットなどを考慮して、さまざまな方法論が使用され、種ごとにさまざまなオプションを渡す必要があるため、特に複雑な比較的大きなデータセット (分布種アトラス) を扱っています。種は、ある季節に存在し、別の季節には見逃されることがあります（繁殖者、居住者、または渡り鳥である可能性があります）。マップはすべてのケース (季節) に対して作成する必要があり、存在しない場合は空になります。追加のデータ (フィールドワークからのデータ以外) が利用可能であり、使用される場合があります。マップの凡例は、関心のある変数 (存在量) をカスタムの離散スケールで表示する以外に、すべてのバリエーションに対応する必要があります。
ループを実行することで、必要ないくつかのオブジェクトをより簡単に保持および制御できると感じていますが、関心のある部分を生成するために作成したフラックスに足を踏み入れ、最終的に種分布マップのセットを作成します。
私の問題は、結果の各 ggplot を list() オブジェクトに格納していることです。各季節の各種がリストに格納されます。私が直面している問題は、loop内で使用されるとき のscale_fill_manualに関連しています。
マップを完成させたので、動作は奇妙ですが、色は最後の ggplot 出力にのみ適用されます。それにもかかわらず、すべての値は凡例で正しく識別されています。
例を挙げると:
パッケージ
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)
最初に簡単な例
#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]])
}
私のセッションでは、plot.l[ 1 ] は、palette.l[ 2 ]の色で塗りつぶされます。
私の特定のケース
機能
プロットの配置
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
}
}
}
ビューポート
VPortLayout <- function(x, y) viewport(layout.pos.row=x, layout.pos.col=y)
種データセット
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
種一覧
list.esp.1 <- c("Sylv mela", "Saxi rube","Ocea leuc")#
# download from the above link
一部の分類とその他のデータ
txcon.1 <- structure(list(id = c(156L, 359L, 387L), grupo = c("Aves", "Aves",#
# download from the above link
季節
kSeason.1 <- c("Inverno", "Primavera", "Outono")
サンプルグリッド
grid500.df.1 <- structure(list(id = c("K113", "K113", "K113", "K113", "K113",#...
# download from the above link
追加のマッピング要素
海岸線
coastline.df.1 <- structure(list(long = c(182554.963670234, 180518, 178865.39,#...
# download from the above link
ラベル配置の調整
kFacx1 <- c(9000, -13000, -10000, -12000)
Rコード
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])]] は、ポリゴンにカラー パレットが適用された唯一のものですが、凡例項目は j マップごとに明確に定義されています。
R コードを使用した出力
ご覧のとおり、凡例は問題ありませんが、色付けされていません。
何も欠けていないことを願っています。ポルトガル語の用語がいくつか失われてしまい、申し訳ありません。