-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy path3.0 comparison_functions.R
144 lines (119 loc) · 5.94 KB
/
3.0 comparison_functions.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
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
57
58
59
60
61
62
63
64
65
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
128
129
130
131
132
133
134
135
136
137
#' Get list of countries compared
#'
#' @param data df with forecasts at different horizons for two different sources and actual values (named respectively variable1/2/3/4,
#' wb1/2/3/4 and targety_first)
#' @param export_path character string. Path to export table.
#' @return Output is a tex table with name of countries in comparison df and geographical group.
get_list_comparison <- function(data,export_path){
data %>%
group_by(country) %>%
slice(1) %>%
select(country, group) %>%
arrange(group) %>%
rename(Country = country, `Geo. group` = group) %>%
stargazer(summary = F,
rownames = F,
out = paste0("../When_where_and_why_material/output/tables/comparison/",export_path))
}
#' Get list of countries compared for Consensus
#'
#' We use a separate function to know for which subsample of countries we have individual level forecasts
#' Previous function only for aggregate
#'
#' @param data df with forecasts at different horizons for Consensus and WEO (variable 1/2/3/4 and consensus 1/2/3/4)
#' @param export_path character string. Path to export table.
#' @return Output is a tex table with name of countries in comparison df and geographical group.
get_list_comparison_consensus <- function(data,export_path){
data %>%
mutate(individual_level = case_when(forecaster != "Consensus (Mean)" ~ "Yes",
T ~ 'No')) %>%
group_by(country) %>%
arrange(forecaster) %>%
slice(1) %>%
select(country, group, individual_level) %>%
arrange(group) %>%
rename(Country = country, `Geo. group` = group, `Individual Level` = individual_level) %>%
stargazer(summary = F,
rownames = F,
out = paste0("../When_where_and_why_material/output/tables/comparison/",export_path))
}
#' Produce scatterplot two institutions forecasts for different horizons
#'
#' @param data df with forecasts at different horizons for two different sources and actual values (named respectively variable1/2/3/4,
#' wb1/2/3/4 and targety_first)
#' @param ylab character. Name of the y-axis.
#' @param ylimits numeric vector. Limits of the y-axis.
#' @param xlimits numeric vector. Limits of the x-axis.
#' @param issues character string. Name of the different issues/forecast horizons.
#' @param export_path character string. Main path to export graphs.
#' @return Pdfs with scatterplots.
get_scatterplot <- function(data, ylab, ylimits = c(-20,20), xlimits=c(-20,20), issues = c("currentJun","currentJan","aheadJun","aheadJan"), export_path){
list <- list(data %>% select(matches("1|group")),
data %>% select(matches("2|group")),
data %>% select(matches("3|group")),
data %>% select(matches("4|group"))) %>%
map(~ .x %>% select(group,everything()))
scatter_forecasts <- list %>%
map(~ .x %>%
ggplot(aes_string(names(.x)[[2]],names(.x)[[3]],col=names(.x)[[1]])) +
geom_point(size=4) +
geom_abline(intercept = 0,slope = 1, color = "red", size=1.2) +
theme_minimal() +
xlim(ylimits) +
ylim(xlimits) +
xlab("WEO Forecasts") +
ylab(ylab) +
labs(col="") +
theme(legend.position = "bottom") +
theme(axis.text = element_text(size = 18),
axis.title = element_text(size = 21),
legend.title = element_text(size = 18),
legend.text = element_text(size = 16)))
scatter_forecasts %>%
walk2(issues,
~ ggsave(paste0("../When_where_and_why_material/output/figures/comparison/",export_path,.y,".pdf"),plot = .x))
}
#' Produce accuracy table comparison
#'
#' @param data df with forecasts at different horizons for two different sources and actual values (named respectively variable1/2/3/4,
#' wb1/2/3/4 and targety_first)
#' @param issues_abbr character string. Name of the different issues/forecast horizons for the table.
#' @param other_var character. Common start of comparison variable.
#' @param export_path character string. Path to export table.
#' @return Accuracy table with percentage countries with lower rmse and t-statistic of Diebold-Mariano
#' for each geographical group.
get_accuracy_summary <- function(data, issues_abbr, other_var, export_path){
percentage <- group %>%
merge(rmse_comparison, by=c("country_code")) %>%
mutate_at(vars(ratio1:ratio4), funs(case_when(. < 0 ~ 1,
T ~ 0))) %>%
group_by(group) %>%
summarise_at(vars(ratio1:ratio4), mean, na.rm = T) %>%
mutate_at(vars(contains("ratio")),funs(round(.,2))) %>%
setNames(c("Geo.group",issues_abbr)) %>%
mutate(Variable = "Percentage")
significance <- data %>%
mutate_at(vars(matches(paste0("variable|",other_var))),funs(targety_first - .)) %>%
split(.$group) %>%
map(~ list(.x %>% select(matches("1")),
.x %>% select(matches("2")),
.x %>% select(matches("3")),
.x %>% select(matches("4")))) %>%
modify_depth(2, ~ .x %>% filter(complete.cases(.))) %>%
modify_depth(2, ~ dm.test(.x[[1]],.x[[2]])) %>%
modify_depth(2, ~.x[["statistic"]]) %>%
map(~ .x %>% bind_cols()) %>%
bind_rows(.id = "Geo. group") %>%
setNames(c("Geo.group",issues_abbr)) %>%
mutate_at(vars(contains("=")), funs(round(.,2))) %>%
mutate_at(vars(contains("=")),funs(case_when(. > 1.96 | . < -1.96 ~ str_replace(as.character(.), "$","**"),
(. > 1.68 & . < 1.96) | (. < -1.68 & . > -1.96) ~ str_replace(as.character(.), "$", "*"),
TRUE ~ as.character(.)))) %>%
mutate(Variable = "DM Test")
rbind(percentage,significance) %>%
arrange(Geo.group) %>%
select(Geo.group, Variable, everything()) %>%
stargazer(out= paste0("../When_where_and_why_material/output/tables/comparison/",export_path),
summary = F,
rownames = F)
}