Newer
Older
#' element textbox highlight
element_textbox_highlight <- function(..., hi.labels = NULL, hi.fill = NULL,
hi.col = NULL, hi.box.col = NULL, hi.family = NULL) {
structure(
c(element_textbox(...),
list(hi.labels = hi.labels, hi.fill = hi.fill, hi.col = hi.col, hi.box.col = hi.box.col, hi.family = hi.family)
),
class = c("element_textbox_highlight", "element_textbox", "element_text", "element")
)
}
#' define color
colorMode <- function(){
RedYellowGreen <- c("#FF0000", "#FF3F00","#FF6600", "#FF9900","#FFCC00",
"#FFFF00",
"#DDF000","#BCE200","#9BD300","#7AC500","#59B600","#38A800")
# RedYellowGreen <- c(scales::seq_gradient_pal("red", "yellow", "Lab")(seq(0,1,length.out=6)),
# scales::seq_gradient_pal("yellow", "green", "Lab")(seq(0,1,length.out=6))[2:6])
return(RedYellowGreen)
}
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
#' caprir map
#'
#' @param baseline Baseline.
#' @param scenario Target.
#' @param comparison Comparision baseline with scenario. Default is TRUE.
#' @param percent_change Calculate percentage changes or abslout difference, default is TRUE.
#' @param quantile_Size number of quantile groups, default = 11.
#' @return A plot.
#'
#' @export
#' @examples
#' map_capri(baseline = benchmark, scenario = scenario, comparison = TRUE, percent_change = TRUE)
#'
map_capri <- function(baseline, scenario, comparison = TRUE, percent_change=FALSE, quantile_Size = 11){
if (comparison==FALSE){
mySel <- baseline
# mySel$group <- cut(mySel$value,
# c(min(mySel$value)-1,0,1000,2000,3000,5000,max(mySel$value)),
# labels = c("0","<1000","<2000","<3000","<5000","<295178.1"))
# # legend_title <- "baseline"
# mySel$group <- cut2(mySel$value, g = quantile_Size)
}else{
message("compare baseline with scenario")
mySel <- baseline %>%
left_join(scenario %>% select(region,cols,value),by=c("region","cols")) %>%
mutate(
value = `if`(percent_change==TRUE,
100*(value.y/value.x-1),
value.y-value.x)) %>%
mutate_at( vars(value),~replace(., is.nan(.), NA))
}
# quantile groups
mySel$group <- cut2(mySel$value, g = quantile_Size)
mySel <- mySel %>%
mutate(min = round(as.numeric(sub("(\\(|\\[)([^,]+),.*", "\\2", group)),0) )
# mySel$min <- ifelse(!is.na(mySel$min), paste0(as.factor(mySel$min), "%"), NA )
# mySel$lvs <- ""
mySel$lvs <- ifelse(!is.na(mySel$min), `if`(percent_change == TRUE, paste0(mySel$min, "%"), mySel$min), NA )
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
mySel$lvs <- factor(mySel$lvs, levels = unique(mySel$lvs[order(mySel$min)]))
print(mySel)
orderfacet1= c("Cereals","Rape seed","Soya seed","Pulses")
orderfacet2 = c("Fodder maize",
"Other fodder from arable land",
"Gras and grazings extensive",
"Gras and grazings intensive")
if ("Cereals" %in% mySel$label) {orderfacet = orderfacet1} else {orderfacet = orderfacet2}
p <- mySel %>%
left_join(map_data_use,by=c("region"="CAPRI_NUTS_ID")) %>%
filter(!is.na(longitude) & !is.na(latitude)) %>%
ggplot(aes(longitude, latitude, group = name, fill = lvs)) +
geom_polygon(color = gray(0.5)) +
geom_path(color = "black" , size = 0.5) +
# coord_map("stereographic") +
# coord_map("albers", lat0=30, lat1=35) +
coord_map(projection = "lambert",
parameters = c(lat0 = 30 , lat1 = 35)) +
# scale_fill_gradient2(low = "#FF0000", mid = "yellow", high = "#00FF00") +
scale_fill_manual(values = colorMode(),
name = "") +
# scale_fill_discrete(name = legend_title ) +
labs(x = "", y = "") +
theme(
panel.background = element_rect(fill = "transparent"), # bg of the panel
plot.background = element_rect(fill = "transparent", color = "transparent"), # bg of the plot
panel.grid.major = element_blank(), # get rid of major grid
panel.grid.minor = element_blank(), # get rid of minor grid
legend.background = element_rect(fill = "transparent"), # get rid of legend bg
legend.box.background = element_rect(fill = "transparent", colour = NA), # get rid of legend panel bg
axis.text.x = element_blank(),
axis.text.y = element_blank(),
axis.ticks = element_blank(),
legend.position = 'bottom',
legend.direction = "horizontal",
legend.box = 'horizontal',
legend.key = element_rect(fill = "transparent", color = "transparent"),
legend.key.height= unit(0.2, 'cm'),
legend.key.width= unit(1.5, 'cm'),
# legend.key.size = unit(0.5, "cm"),
legend.text.align = 0,
strip.text = element_textbox_highlight(
size = 10,
# face = "bold",
fill = "white",
box.color = "white",
halign = .5, linetype = 1, r = unit(0, "pt"), width = unit(1, "npc"),
padding = margin(0, 0, 0, 0), margin = margin(0, 0, 0, 0),
hi.fill = "white", hi.box.col = "white", hi.col = "white")) +
facet_wrap(~factor(label, levels= orderfacet),nrow = 1) +
guides(fill = guide_legend(nrow = 1,
byrow = TRUE,
title.hjust = 0.5,
label.position = "bottom"))
# if (saveP == TRUE) ggsave("p.png", plot = p,width = 16, height = 9, dpi = 100)
return(p)
}