if (!require("pacman")) install.packages("pacman")
pacman::p_load(
tidyverse,
devtools,
httr,
readxl,
dlookr,
ggtext,
gt,
gtExtras, #for font awesome icons in gt tables
ggbump,
ggcirclepack,
showtext,
tidycountries,
janitor, #for clean_names()
scales,
patchwork,
htmltools, #for tagList()
glue,
here,
geomtextpath
)
# install_github("EvaMaeRey/ggcirclepack")Response [https://download.data.world/file_download/makeovermonday/2024w47-global-slavery-index/MM%20W49%20-%20Global%20Slavery%20Index%202023.xlsx?auth=eyJhbGciOiJIUzUxMiJ9.eyJzdWIiOiJwcm9kLXVzZXItY2xpZW50Om1yYWZhMyIsImlzcyI6ImFnZW50Om1yYWZhMzo6ODg0MjQ2ZDItMTgzMy00NmZjLTk2YTMtZjQ2MWMzMDJjOTZiIiwiaWF0IjoxNzM0MDE4Mzg5LCJyb2xlIjpbInVzZXIiLCJ1c2VyX2FwaV9hZG1pbiIsInVzZXJfYXBpX2VudGVycHJpc2VfYWRtaW4iLCJ1c2VyX2FwaV9yZWFkIiwidXNlcl9hcGlfd3JpdGUiXSwiZ2VuZXJhbC1wdXJwb3NlIjpmYWxzZSwidXJsIjoiNjI5OGY4ZmE0MDlkZTYxNTk5ZjFmM2M1Zjk4YjA1ZjVkYzcyZmE1ZCJ9.41u7KXt0E1E6-eg9iVwIiM5F-9nxsSrpPHJJnTtHXVoynnZWCU5kBr2b3B6OGXtBMjOkJXsDt4ybxJbSW5nn7g]
Date: 2024-12-13 19:41
Status: 200
Content-Type: application/vnd.openxmlformats-officedocument.spreadsheetml.sheet
Size: 126 kB
<ON DISK> /var/folders/ck/dmgn8lbx6vl8sl89vlhr0sv00000gn/T//RtmpaCTAYz/file83f05ef8698c.xlsx# A tibble: 17 × 6
variables types missing_count missing_percent unique_count unique_rate
<chr> <chr> <int> <dbl> <int> <dbl>
1 country char… 0 0 180 1
2 population nume… 0 0 176 0.978
3 region char… 0 0 5 0.0278
4 estimated_preva… nume… 20 11.1 161 0.894
5 estimated_numbe… nume… 20 11.1 118 0.656
6 governance_issu… nume… 20 11.1 161 0.894
7 lack_of_basic_n… nume… 20 11.1 161 0.894
8 inequality_vuln… nume… 20 11.1 160 0.889
9 disenfranchised… nume… 20 11.1 160 0.889
10 effects_of_conf… nume… 20 11.1 160 0.889
11 total_vulnerabi… nume… 20 11.1 161 0.894
12 survivors_of_sl… nume… 4 2.22 21 0.117
13 criminal_justic… nume… 4 2.22 19 0.106
14 coordination_oc… nume… 4 2.22 8 0.0444
15 risk_factors_su… nume… 4 2.22 14 0.0778
16 government_and_… nume… 4 2.22 5 0.0278
17 government_resp… nume… 4 2.22 42 0.233 df <- df %>%
mutate(country = case_match(country,
'Türkiye' ~ 'Turkey',
'United States of America' ~ 'United States',
'Democratic Republic of the Congo' ~ 'DR Congo',
'Viet Nam' ~ 'Vietnam',
"Côte d'Ivoire" ~ 'Ivory Coast',
'Lao PDR' ~ 'Laos',
'Brunei Darussalam' ~ 'Brunei',
.default = country),
percentile_nmbr_in_slavery =
round(100 * percent_rank(estimated_number_of_people_in_modern_slavery), 0),
rank_prevalence = rank(-estimated_prevalence_of_modern_slavery_per_1_000_population),
rank_absolute = round(rank(-estimated_number_of_people_in_modern_slavery), 0),
perc_ttl_nmbr_in_slavery = estimated_number_of_people_in_modern_slavery / sum(estimated_number_of_people_in_modern_slavery, na.rm=TRUE)) %>%
left_join(x=.,
y=country_df,
by=c('country' = 'common_name'))
This is an interesting dataset that reminds me of some work that I contributed to at the Pardee Center. There’s a lot that could be explored here, including things like mapping or analyzing the data with cluster analysis or PCA.
I like a chart to display this information, but there’s some elements that I’ll reconsider:
region_cols <- c('Asia and the Pacific' = "#8dd3c7",
'Europe and Central Asia' = "#ffffb3",
'Africa' = "#bebada",
'Americas' = "#fb8072",
'Arab States' = "#80b1d3")
region_cols_alpha <- sapply(region_cols, alpha, alpha = 0.2)
my_theme <- theme(
text = element_text(family = 'Lato', size=12, color='black'),
axis.ticks = element_blank(),
plot.background = element_rect(color='white'),
panel.background = element_blank(),
legend.background = element_blank(),
panel.grid.major = element_blank(),
panel.grid.minor = element_blank(),
panel.border = element_blank(),
legend.title=element_blank(),
legend.position = 'none')gt_walk_free <- df %>%
select(flags_png, country, rank_prevalence, estimated_prevalence_of_modern_slavery_per_1_000_population, estimated_number_of_people_in_modern_slavery, percentile_nmbr_in_slavery) %>%
arrange(rank_prevalence) %>%
slice_max(n=25, estimated_prevalence_of_modern_slavery_per_1_000_population) %>%
gt() %>%
cols_label(country = '',
flags_png = '',
rank_prevalence = 'Rank (Prevalence)',
estimated_prevalence_of_modern_slavery_per_1_000_population = 'Prevalence Rate',
estimated_number_of_people_in_modern_slavery = '# of People (percentile rank)') %>%
tab_header(title = md("**Countries with highest prevalence modern slavery from the Global Slavery Index Report (2023)**"),
subtitle = md("Prevalence defined as the estimated number of people in slavery per 1,000 population<br><br>Highlighted rows indicate countries that are in the top 25% in terms of the number of people in slavery and includes many countries with relatively low prevalence rates, including South Korea, Argentina, Italy, and the United States")) %>%
tab_source_note(source_note = "Estimates from Walk Free's Global Slavery Index Report (2023)") %>%
gt_merge_stack(col1 = estimated_number_of_people_in_modern_slavery, col2 = percentile_nmbr_in_slavery) %>%
fmt_number(columns = estimated_number_of_people_in_modern_slavery,
decimals = 0) %>%
fmt_number(columns = estimated_prevalence_of_modern_slavery_per_1_000_population,
decimals = 1) %>%
gt_img_rows(
columns = flags_png,
height = 10
) %>%
gt_highlight_rows(
rows = percentile_nmbr_in_slavery >= 75,# a logic statement
fill = "gray90",
bold_target_only = FALSE) %>%
tab_style(
style = cell_text(size = px(35)),
locations = cells_title(groups = "title")
) %>%
data_color(columns = estimated_prevalence_of_modern_slavery_per_1_000_population,
palette = c("white", "red")) %>%
gt_theme_538()plot_circlepack <- df %>%
filter(complete.cases(.)) %>%
ggplot(.,
aes(id=country,
area=estimated_number_of_people_in_modern_slavery,
fill=region)) +
ggcirclepack::geom_circlepack(linewidth = 1) +
ggcirclepack::geom_circlepack_text() +
coord_fixed() +
labs(title=glue("<span style='color:#8dd3c7'>**Asia and the Pacific**</span> has an estimated **29 million people in slavery**"),
subtitle='This constitutes nearly **60% of the global estimate** of people in slavery<br>**5 of the top 6 countries** are in the Asia and the Pacific region',
caption='**Source**: Walk Free<br>Global Slavery Index Report (2023)') +
scale_fill_manual(values = region_cols) +
my_theme +
theme(plot.title = element_textbox_simple(size=rel(3.4), margin = margin(t=20, b=6, l=-50),
lineheight = .4),
plot.subtitle = element_textbox(size=rel(2), margin = margin(l=-50), lineheight = .4),
plot.caption = element_textbox(size=rel(1.5), margin = margin(r=-10), lineheight = .4),
axis.text = element_blank())gt_walk_free_region_top_5 <- df %>%
group_by(region) %>%
slice_max(n=5, estimated_number_of_people_in_modern_slavery) %>%
ungroup() %>%
select(flags_png, country, region, estimated_number_of_people_in_modern_slavery, rank_absolute) %>%
gt(groupname_col = 'region') %>%
cols_label(country = '',
flags_png = '',
estimated_number_of_people_in_modern_slavery = '# of People',
rank_absolute = 'Global Rank') %>%
tab_header(title = md("**Estimates of modern slavery by region from the Global Slavery Index (2023)**"),
subtitle = "Top 5 countries in each region shown") %>%
tab_source_note(source_note = "Estimates from Walk Free's Global Slavery Index Report (2023)") %>%
# gt_merge_stack(col1 = estimated_number_of_people_in_modern_slavery, col2 = percentile_nmbr_in_slavery) %>%
fmt_number(columns = estimated_number_of_people_in_modern_slavery,
decimals = 0) %>%
gt_img_rows(
columns = flags_png,
height = 10
) %>%
data_color(columns = estimated_number_of_people_in_modern_slavery,
palette = c("white", "red")) %>%
tab_style(
style = list(
cell_fill(color = region_cols_alpha['Asia and the Pacific']),
cell_text(weight = "bold")
),
locations = cells_row_groups(groups = "Asia and the Pacific")
) %>%
tab_style(
style = list(
cell_fill(color = region_cols_alpha['Europe and Central Asia']),
cell_text(weight = "bold")
),
locations = cells_row_groups(groups = "Europe and Central Asia")
) %>%
tab_style(
style = list(
cell_fill(color = region_cols_alpha['Africa']),
cell_text(weight = "bold")
),
locations = cells_row_groups(groups = "Africa")
) %>%
tab_style(
style = list(
cell_fill(color = region_cols_alpha['Americas']),
cell_text(weight = "bold")
),
locations = cells_row_groups(groups = "Americas")
) %>%
tab_style(
style = list(
cell_fill(color = region_cols_alpha['Arab States']),
cell_text(weight = "bold")
),
locations = cells_row_groups(groups = "Arab States")
) %>%
tab_style(
style = cell_text(size = px(35)),
locations = cells_title(groups = "title")
) %>%
gt_theme_538()# TOP 25 PREVALENCE TABLE
gt_walk_free %>%
gtsave(
filename = glue("mm_{mm_year}_{mm_week}.png"),
path = here::here('.//visualizations/2024-12-12-mm-wk47-2024/')
)
# CIRCLE PLOT
ggsave(
filename = glue("mm_{mm_year}_{mm_week}_circlepack.png"),
plot = plot_circlepack,
width = 4, height = 4, units = "in", dpi = 320
)
# TOP 5 BY REGION TABLE
gt_walk_free_region_top_5 %>%
gtsave(
filename = glue("mm_{mm_year}_{mm_week}_top5_by_region.png"),
path = here::here('.//visualizations/2024-12-12-mm-wk47-2024/')
)
# make thumbnail for page
magick::image_read(glue("mm_{mm_year}_{mm_week}_circlepack.png")) %>%
magick::image_resize(geometry = "400") %>%
magick::image_write(glue("mm_{mm_year}_{mm_week}_thumbnail.png"))R version 4.4.0 (2024-04-24)
Platform: aarch64-apple-darwin20
Running under: macOS Sonoma 14.6.1
Matrix products: default
BLAS: /Library/Frameworks/R.framework/Versions/4.4-arm64/Resources/lib/libRblas.0.dylib
LAPACK: /Library/Frameworks/R.framework/Versions/4.4-arm64/Resources/lib/libRlapack.dylib; LAPACK version 3.12.0
locale:
[1] en_US.UTF-8/en_US.UTF-8/en_US.UTF-8/C/en_US.UTF-8/en_US.UTF-8
time zone: America/Denver
tzcode source: internal
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] geomtextpath_0.1.4 here_1.0.1 glue_1.8.0
[4] htmltools_0.5.8.1 patchwork_1.3.0 scales_1.3.0
[7] janitor_2.2.0 tidycountries_0.1.0 showtext_0.9-7
[10] showtextdb_3.0 sysfonts_0.8.9 ggcirclepack_0.0.0.9000
[13] ggbump_0.1.0 gtExtras_0.5.0 gt_0.11.1
[16] ggtext_0.1.2 dlookr_0.6.3 readxl_1.4.3
[19] httr_1.4.7 devtools_2.4.5 usethis_3.0.0
[22] lubridate_1.9.3 forcats_1.0.0 stringr_1.5.1
[25] dplyr_1.1.4 purrr_1.0.2 readr_2.1.5
[28] tidyr_1.3.1 tibble_3.2.1 ggplot2_3.5.1
[31] tidyverse_2.0.0 pacman_0.5.1
loaded via a namespace (and not attached):
[1] rstudioapi_0.17.1 jsonlite_1.8.9 magrittr_2.0.3
[4] magick_2.8.5 farver_2.1.2 rmarkdown_2.28
[7] ragg_1.3.3 fs_1.6.4 vctrs_0.6.5
[10] memoise_2.0.1 paletteer_1.6.0 base64enc_0.1-3
[13] curl_5.2.3 cellranger_1.1.0 sass_0.4.9
[16] KernSmooth_2.23-24 htmlwidgets_1.6.4 fontawesome_0.5.2
[19] cachem_1.1.0 commonmark_1.9.2 mime_0.12
[22] lifecycle_1.0.4 pkgconfig_2.0.3 webshot2_0.1.1
[25] R6_2.5.1 fastmap_1.2.0 shiny_1.9.1
[28] snakecase_0.11.1 digest_0.6.37 colorspace_2.1-1
[31] rematch2_2.1.2 ps_1.8.0 rprojroot_2.0.4
[34] pkgload_1.4.0 textshaping_0.4.0 labeling_0.4.3
[37] fansi_1.0.6 timechange_0.3.0 compiler_4.4.0
[40] proxy_0.4-27 remotes_2.5.0 fontquiver_0.2.1
[43] withr_3.0.2 backports_1.5.0 DBI_1.2.3
[46] pkgbuild_1.4.4 Rttf2pt1_1.3.12 sessioninfo_1.2.2
[49] classInt_0.4-10 tools_4.4.0 chromote_0.3.1
[52] units_0.8-5 reactable_0.4.4 httpuv_1.6.15
[55] extrafontdb_1.0 promises_1.3.0 gridtext_0.1.5
[58] grid_4.4.0 sf_1.0-18 checkmate_2.3.2
[61] generics_0.1.3 gtable_0.3.6 tzdb_0.4.0
[64] class_7.3-22 websocket_1.4.2 hms_1.1.3
[67] xml2_1.3.6 utf8_1.2.4 pillar_1.9.0
[70] markdown_1.13 later_1.3.2 tidyselect_1.2.1
[73] pagedown_0.21 fontLiberation_0.1.0 miniUI_0.1.1.1
[76] knitr_1.48 fontBitstreamVera_0.1.1 gridExtra_2.3
[79] svglite_2.1.3 xfun_0.48 stringi_1.8.4
[82] yaml_2.3.10 kableExtra_1.4.0 evaluate_1.0.1
[85] extrafont_0.19 gdtools_0.4.0 packcircles_0.3.7
[88] cli_3.6.3 xtable_1.8-4 systemfonts_1.1.0
[91] munsell_0.5.1 processx_3.8.4 Rcpp_1.0.13-1
[94] ellipsis_0.3.2 profvis_0.4.0 urlchecker_1.0.1
[97] viridisLite_0.4.2 hrbrthemes_0.8.7 e1071_1.7-16
[100] rlang_1.1.4