In EBukin/devPTIpack: Development environment for Precise Index Targeting analysis

knitr::opts_chunk$set(fig.width = 12, 
                      fig.height = 5,
                      # fig.asp = 3/4,
                      # out.width = "60%",
                      # fig.align = "center",
                      # dpi = 150,
                      message = FALSE,
                      echo = FALSE,
                      warning = FALSE,
                      error = FALSE,
                      cache = FALSE
                      )

# Packages
conflictRules("tidyr", mask.ok = c("extract"))
conflictRules("dplyr", mask.ok = c("filter", "lag", "select"))

pacman::p_load(sf, #raster,
               rmapshaper, here, fs, tidyverse, dplyr, readxl,
               ggpubr,gridExtra, patchwork, writexl, scales, leaflet, mapview)
library(devPTIpack)

mtdt_path <- here::here("app-data") %>% list.files(".xlsx$", full.names = T) %>% `[`(length(.)) %>% `[[`(1)
bond_path <- here::here("app-data") %>% list.files(full.names = T) %>% 
  `[`(str_detect(., regex("rds", ignore_case = T))) %>% 
  `[`(length(.)) %>% `[[`(1)



mtdt <- 
  readxl::excel_sheets(mtdt_path) %>% 
  map(~{
    set_names(list(readxl::read_xlsx(mtdt_path, sheet = .x)), .x)
  }) %>% 
  unlist(recursive = F)

metadata_current <- 
  mtdt$metadata %>% 
  filter(!fltr_exclude_pti | !fltr_exclude_explorer)

data_current <- 
  mtdt %>%
  `[`(str_detect(names(.), "admin\\d"))
# names(data_current) <- names(data_current) %>% str_extract("^admin\\d{1,2}")

bounds <-bond_path %>% read_rds()

# Saving shape files in a Zip archive
shp_fldr <- bond_path %>% str_replace_all("\\.rds", "_shapes")
shp_path <- str_c(shp_fldr, ".zip")
if (!file.exists(shp_path) ||
    file.info(bond_path)$mtime > file.info(shp_path)$mtime) {
  dir.create(shp_fldr, recursive = T, showWarnings = F)
  bounds %>%
    iwalk( ~ {
      file <- shp_fldr %>% file.path(.y)
      sf::st_write(.x,
                   file,
                   driver = "ESRI Shapefile",
                   append = FALSE,
                   quiet = TRUE)
    })
}

# meta_line <- slice(metadata_current, 5)
one_section <-
  function(meta_line,
           plot_data) {
    cat("\n\n\n### ", meta_line$var_name, "\n\n\n")

    if (
      !is.na(meta_line$var_description) &&
      !identical(meta_line$var_description, character(0)) &&
        nchar(meta_line$var_description) > 10)
      cat("**Description:** ", meta_line$var_description, "\n\n\n")

    spatial_level_adm <- meta_line$spatial_level %>% str_extract(., "admin\\d")
    var_to_plot_raw <- plot_data[[meta_line$spatial_level]] %>%
      select(contains(spatial_level_adm), one_of(meta_line$var_code))

    vals_to_plot <- var_to_plot_raw %>%
      select(one_of(meta_line$var_code)) %>% pull()

    legend_info <-
      legend_map_satelite(
        vals_to_plot,
        n_groups = 5,
        legend_paras = list(legend_revert_colours = meta_line$legend_revert_colours)
      )

    # if (length(unique(vals_to_plot)) > 12) {
      var_to_plot <-
        var_to_plot_raw %>%
        mutate(across(
          any_of(meta_line$var_code),
          ~ legend_info$recode_function_intervals(.) %>%
            factor(levels = legend_info$our_labels)
        ))
    # } else {
    #   var_to_plot <-
    #     var_to_plot %>%
    #     mutate(across(any_of(meta_line$var_code), ~ as.factor(.)))
    # }

    map_gg <-
      gg_admin_list(var_to_plot, metadata = metadata_current, mt = bounds) %>%
      `[[`(1) + scale_fill_manual(values = legend_info$pal(legend_info$our_values))

    local_cols <- brewer_pal("div", 7)(7)
    labeler <- function(x) {
      new_num <- try({scales::label_number_auto(x)}, silent = T)
      if ("try-error" %in% class(new_num)) {
        new_num <- round(x, 3)
      }
      new_num
      }

    sum_stats_plot <-
      gghistogram(
        var_to_plot_raw,
        x = meta_line$var_code,
        add = "median",
        rug = TRUE,
        color = local_cols[2],
        fill = local_cols[2]
      )

    sum_stats_plot_dta <- ggplot_build(sum_stats_plot)

    sum_stats_plot <-
      sum_stats_plot +
      geom_text(aes(
        x = mean(vals_to_plot, na.rm = T),
        label = "mean",
        y = max(sum_stats_plot_dta$data[[1]]$count) * 0.85
      ),
      colour = local_cols[6]) +
      geom_text(aes(
        x = median(vals_to_plot, na.rm = T),
        label = "median",
        y = max(sum_stats_plot_dta$data[[1]]$count) * 1.05
      ),
      colour = local_cols[2])

    sum_stats_tab <-
      psych::describe(vals_to_plot, fast = T, na.rm = TRUE) %>%
      as_tibble() %>%
      select(-vars) %>%
      imap( ~ {
        labeler(as.numeric(.x))
      }) %>%
      as_tibble() %>%
      gridExtra::tableGrob(theme = gridExtra::ttheme_minimal(base_colour  = local_cols[1]),
                           rows = NULL)

    lay <- "AACCCAACCCBBCCC"

    print((
      sum_stats_plot / sum_stats_tab + plot_layout(heights =  c(9, 1)) |
        map_gg
    ) +
        plot_layout(widths = c(2, 3)))

  }



# var_to_plot <-
# slice(metadata_current, 60) %>%
# # meta_line <-
#   metadata_current %>%
#   slice(4) %>%
#   # filter(metadata_current, var_code == "rri") %>%
#   one_section(data_current)
# 
# plot_data <- data_current



#   # mutate(across(
#   #   any_of(meta_line$var_code),
#   #   ~ cut(
#   #     .,
#   #     breaks = legend_info$our_breaks_full,
#   #     labels = legend_info$our_labels[!is.na(legend_info$our_labels)],
#   #     include.lowest = T,
#   #     ordered_result = FALSE
#   #   ) %>%
#   #     as_factor() %>%
#   #     fct_relevel(legend_info$our_labels)
#   # ))
# 
# vals_to_plot <-
#   var_to_plot %>%
#   select(one_of(meta_line$var_code)) %>%
#   pull()
# 
# legend_info <-
#   legend_map_satelite(vals_to_plot, n_groups = 6,
#                     legend_paras = list(
#                       legend_revert_colours = meta_line$legend_revert_colours
#                     ))
# 
# vals_to_plot %>%
#     cut(breaks = legend_info$our_breaks_full,
#         labels = legend_info$our_labels[!is.na(legend_info$our_labels)],
#         include.lowest = T,
#         ordered_result = FALSE
#         ) %>%
#   as_factor() %>%
#   fct_relevel(legend_info$our_labels)
# 
# legend_info$recode_function
# 
# 
# 
# 
# map_gg <-
#   gg_admin_list(var_to_plot, metadata = metadata_current)
# 
# ppal <- brewer_pal(type = "div", 7)
# 
# map_gg[[1]] +
#     scale_fill_brewer(type = "div", palette = 7)
# 
# (
#     # breaks = legend_info$our_breaks,
#     midpoint = median(vals_to_plot, na.rm = T)
#     # colours = terrain.colors(10)
#   )
# #   scale_fill_binned(
# #     type = ppal,
# #     n = 8
# #      # guide = guide_coloursteps(even.steps = T, show.limits = T)
# #   )
# # 
# # brewer_pal("")
# # # map_gg[[1]] +
# # #   scale_fill_viridis_c(
# # #     # palette = "RdYlBu",
# # #     breaks = rev(legend_info$our_breaks),
# # #     # na.value = "No data" ,
# # #   # labels = waiver(),
# # #   guide = guide_coloursteps(even.steps = T, show.limits = T)
# # #   )
# # #
# # #
# # # binned(
# # #
# # #   breaks = legend_info$our_breaks,
# # #   guide = guide_coloursteps(even.steps = T, show.limits = T)
# # #   )
# # #
# # #
# # #   option = "C",
# # #   direction = -1,
# # #   begin = 0.4#,
# # #   # breaks = legend_info$our_values,
# # #   # labels = legend_info$our_labels
# # # )

metadata_current %>%
  # sample_n(10) %>%
  arrange(pillar_group, var_order, var_name) %>%
  group_by(pillar_group) %>%
  nest() %>%
  pwalk(~ {
    cat("\n\n\n## ", .y$pillar_name[[1]], "\n\n\n\n\n")

    .y %>%
      group_by(row_number()) %>%
      nest() %>%
      pwalk( ~ {
        # browser()
        # cat(.y$var_name, "\n")
        try({
          one_section(.y, data_current)
        })

      })

  })