New Functions in waffle-plot-dev Branch

DESCRIPTION

@@ -2,7 +2,7 @@ Package: consequencestools
 Type: Package
 Title: Provides Support Tools for Data Analysis and Visualization 
     from the Ultimate Consequences Database
-Version: 0.0.0.9010
+Version: 0.0.0.9011
 Authors@R: 
     person(
     "Carwil", "Bjork-James",
@@ -28,6 +28,7 @@ Imports:
     assertthat,
     dplyr,
     forcats,
+    ggplot2,
     grDevices,
     incase,
     lubridate,
@@ -42,6 +43,7 @@ Imports:
     tidyselect,
     transcats (>= 0.0.0.9002),
     utils,
+    waffle (>= 1.0.2),
     zoo
 Depends: 
     R (>= 3.5)

NAMESPACE

@@ -29,11 +29,14 @@ export(clean_pt_variables)
 export(col2hex)
 export(combine_dates)
 export(combine_names)
+export(complete_x_values)
 export(count_events_in_month)
 export(count_ongoing_events)
 export(count_range_by)
 export(department_name_from_id)
 export(displayed_date_string)
+export(domain_filename)
+export(domain_filename_es)
 export(estimated_date)
 export(estimated_date_string)
 export(event_counts_by)
@@ -54,6 +57,8 @@ export(id_for_event)
 export(id_for_municipality)
 export(id_for_municipality_2)
 export(id_for_president)
+export(make_waffle_chart)
+export(make_waffle_chart_tall)
 export(muni_counts_by)
 export(muni_list_with_counts_by)
 export(municipality_name_from_id)
@@ -66,6 +71,7 @@ export(perp_pal)
 export(province_name_from_id)
 export(quasilogical_as_binary)
 export(red_pal)
+export(relabel_pres_admin)
 export(rename_anexo_columns)
 export(render_age)
 export(render_age_es)
@@ -77,6 +83,8 @@ export(repair_name_line_es)
 export(sep_pal)
 export(set_maximums)
 export(share_of_largest_n)
+export(sorted_by_most_frequent)
+export(sorted_by_widest_appearance)
 export(standard_filter)
 export(str_equivalent)
 export(str_equivalent_list)
@@ -85,6 +93,7 @@ export(sv_pal)
 export(top_values_string)
 export(truncate_event_list)
 export(truncate_muni_list)
+export(waffle_counts)
 export(wide_event_outcomes_reactable)
 export(wide_event_outcomes_table)
 import(dplyr)
@@ -113,6 +122,22 @@ importFrom(forcats,fct_collapse)
 importFrom(forcats,fct_explicit_na)
 importFrom(forcats,fct_na_value_to_level)
 importFrom(forcats,fct_relevel)
+importFrom(ggplot2,aes)
+importFrom(ggplot2,coord_equal)
+importFrom(ggplot2,element_blank)
+importFrom(ggplot2,element_line)
+importFrom(ggplot2,element_text)
+importFrom(ggplot2,facet_wrap)
+importFrom(ggplot2,geom_vline)
+importFrom(ggplot2,ggplot)
+importFrom(ggplot2,guide_legend)
+importFrom(ggplot2,scale_fill_manual)
+importFrom(ggplot2,scale_x_continuous)
+importFrom(ggplot2,scale_x_discrete)
+importFrom(ggplot2,scale_y_continuous)
+importFrom(ggplot2,scale_y_discrete)
+importFrom(ggplot2,theme)
+importFrom(ggplot2,theme_minimal)
 importFrom(grDevices,col2rgb)
 importFrom(grDevices,colorRamp)
 importFrom(grDevices,rgb)
@@ -124,7 +149,9 @@ importFrom(reactable,colDef)
 importFrom(reactablefmtr,nytimes)
 importFrom(rlang,"!!!")
 importFrom(rlang,.data)
+importFrom(rlang,enquo)
 importFrom(rlang,list2)
+importFrom(rlang,quo_name)
 importFrom(rlang,sym)
 importFrom(stringi,stri_trans_general)
 importFrom(stringr,str_c)
@@ -141,4 +168,5 @@ importFrom(tidyselect,any_of)
 importFrom(tidyselect,last_col)
 importFrom(transcats,translated_join_vars)
 importFrom(utils,head)
+importFrom(waffle,geom_waffle)
 importFrom(zoo,as.Date.yearmon)

R/consequencestools-package.R

@@ -22,6 +22,22 @@
 #' @importFrom forcats fct_explicit_na
 #' @importFrom forcats fct_na_value_to_level
 #' @importFrom forcats fct_relevel
+#' @importFrom ggplot2 aes
+#' @importFrom ggplot2 coord_equal
+#' @importFrom ggplot2 element_blank
+#' @importFrom ggplot2 element_line
+#' @importFrom ggplot2 element_text
+#' @importFrom ggplot2 facet_wrap
+#' @importFrom ggplot2 geom_vline
+#' @importFrom ggplot2 ggplot
+#' @importFrom ggplot2 guide_legend
+#' @importFrom ggplot2 scale_fill_manual
+#' @importFrom ggplot2 scale_x_continuous
+#' @importFrom ggplot2 scale_x_discrete
+#' @importFrom ggplot2 scale_y_continuous
+#' @importFrom ggplot2 scale_y_discrete
+#' @importFrom ggplot2 theme
+#' @importFrom ggplot2 theme_minimal
 #' @importFrom grDevices col2rgb
 #' @importFrom grDevices colorRamp
 #' @importFrom grDevices rgb
@@ -31,7 +47,9 @@
 #' @importFrom reactablefmtr nytimes
 #' @importFrom rlang !!!
 #' @importFrom rlang .data
+#' @importFrom rlang enquo
 #' @importFrom rlang list2
+#' @importFrom rlang quo_name
 #' @importFrom rlang sym
 #' @importFrom stringi stri_trans_general
 #' @importFrom stringr str_c
@@ -48,6 +66,7 @@
 #' @importFrom tidyselect last_col
 #' @importFrom transcats translated_join_vars
 #' @importFrom utils head
+#' @importFrom waffle geom_waffle
 #' @importFrom zoo as.Date.yearmon
 ## usethis namespace: end
 NULL

R/filename-tools-subset.R

@@ -0,0 +1,42 @@
+#' Generate protest domain filename
+#'
+#' @param protest_domain The protest domain name
+#' @return The corresponding filename for the domain page,
+#'         relative to the root of the website.
+#' @export
+#'
+#' @examples
+#' domain_filename("Rural land")
+domain_filename <- function(protest_domain){
+  # No files for overlapping domains like "Rural land, Partisan politics"
+  name <- stringr::str_replace_all(protest_domain, "\\s+", "-") %>%
+    stringr::str_to_lower() %>%
+    stringi::stri_trans_general("Latin-ASCII")
+  filename <-  str_glue("/domain/{name}.html")
+  return(if_else(stringr::str_detect(protest_domain, ","),
+                 "", # No files for overlapping domains
+                 filename
+  ))
+}
+
+#' Generate Spanish domain filename
+#'
+#' @param protest_domain The protest domain name in Spanish
+#' @return The corresponding filename for the Spanish domain page,
+#'   relative to the root of the website.
+#'
+#' @export
+#'
+#' @examples
+#' domain_filename_es("Campesino")
+domain_filename_es <- function(protest_domain){
+  name <- stringr::str_replace_all(protest_domain, "\\s+", "-") %>%
+    stringr::str_to_lower() %>%
+    stringi::stri_trans_general("Latin-ASCII")
+  filename <-  str_glue("/dominio/{name}.html")
+
+  return(if_else(stringr::str_detect(protest_domain, ","),
+                 "", # No files for overlapping domains
+                 filename
+  ))
+}

R/relabel-pres-admin.R

@@ -0,0 +1,52 @@
+#' Relabel presidential administration using presidency_name_table
+#'
+#' Replaces pres_admin values with corresponding values from a specified column
+#' in presidency_name_table (e.g., presidency_year, presidency_initials, etc.)
+#'
+#' @param dataframe The input dataframe containing a pres_admin column
+#' @param output_column The column from presidency_name_table to use for new labels
+#'   (unquoted column name)
+#' @param .input_column The column from presidency_name_table to match against
+#'   pres_admin (default "presidency")
+#' @param keep_original Logical indicating whether to keep the original pres_admin
+#'   column as pres_admin_original (default TRUE)
+#'
+#' @return The dataframe with pres_admin relabeled according to output_column
+#'
+#' @export
+#'
+#' @examples
+#' def <- assign_presidency_levels(deaths_aug24)
+#' def_labeled <- relabel_pres_admin(def, presidency_year)
+#' def_labeled <- relabel_pres_admin(def, presidency_initials)
+#' def_labeled <- relabel_pres_admin(def, presidency_fullname_es, keep_original = TRUE)
+relabel_pres_admin <- function(dataframe, output_column, .input_column="presidency", keep_original = TRUE) {
+  output_col_name <- rlang::ensym(output_column)
+  input_col_name <- rlang::ensym(.input_column)
+
+  result <- dataframe %>%
+    left_join(select(presidency_name_table, {{input_col_name}}, {{output_column}}),
+              by = join_by(pres_admin == {{input_col_name}}))
+
+  if (keep_original) {
+    result <- result %>%
+      rename(pres_admin_original = pres_admin)
+  } else {
+    result <- result %>%
+      select(-pres_admin)
+  }
+
+  result <- result %>%
+    rename(pres_admin = {{output_column}})
+
+  if(length(unique(presidency_name_table[[rlang::as_name(output_col_name)]])) < nrow(presidency_name_table)) {
+    warning("Some new values are ambiguous. pres_admin not returned as a factor.")
+  } else {
+    result <- result %>%
+      # Make pres_admin a factor in the order specified in presidency_name_table
+      mutate(pres_admin = factor(pres_admin,
+                                 levels = presidency_name_table[[rlang::as_name(output_col_name)]]))
+  }
+
+  return(result)
+}

R/sort-var-description.R

@@ -0,0 +1,129 @@
+#' Sort variable description by widest appearance across groups
+#'
+#' Reorders the levels and colors in a variable description list based on how
+#' widely each level appears across a grouping variable. Levels that appear in
+#' more groups are ranked higher. For example, sorting protest domains by how
+#' many presidential administrations each domain appears in.
+#'
+#' @param var_description A list containing variable metadata with elements:
+#'   \itemize{
+#'     \item \code{r_variable}: Name of the variable in the dataframe
+#'     \item \code{levels}: Character vector of level names
+#'     \item \code{colors}: Named vector of colors for each level
+#'     \item \code{levels_es}: (Optional) Spanish translations of levels
+#'     \item \code{colors_es}: (Optional) Spanish-named color vector
+#'   }
+#' @param def The dataframe containing the data to analyze
+#' @param grouping_var The variable to group by when calculating width of
+#'   appearance (e.g., pres_admin, year). Use unquoted variable name.
+#'
+#' @return A modified variable description list with levels and colors reordered
+#'   by widest appearance. Includes a new \code{$ranked} element with the
+#'   sorted levels.
+#'
+#' @export
+#' @examples
+#' \dontrun{
+#' # Sort protest domains by how many presidential administrations they appear in
+#' deaths <- assign_protest_domain_levels(deaths_aug24)
+#' pd_sorted <- sorted_by_widest_appearance(
+#'   var_description = lev$protest_domain,
+#'   def = deaths,
+#'   grouping_var = pres_admin
+#' )
+#' }
+sorted_by_widest_appearance <- function(var_description, def, grouping_var) {
+  var_name <- var_description$r_variable
+  var_description$ranked <-
+    count(def, {{grouping_var}}, !!sym(var_name)) %>%  # 2-var frequency table
+    count(!!sym(var_name)) %>% # frequency table of number of
+    # values of the grouping variable, with deaths in each value of the variable
+    arrange(desc(n)) %>%              # ranked downward
+    pull(!!sym(var_name))      # vector of the groups
+  new_var_description <- var_description
+
+  # Get the new order based on ranked
+  new_order <- match(new_var_description$ranked, var_description$levels)
+
+  # Reorder levels
+  new_var_description$levels <- var_description$ranked
+
+  # Reorder levels_es if it exists
+  if (!is.null(var_description$levels_es)) {
+    new_var_description$levels_es <- var_description$levels_es[new_order]
+  }
+
+  # Reorder colors
+  new_var_description$colors <- var_description$colors[new_order]
+
+  # Reorder colors_es if it exists
+  if (!is.null(var_description$colors_es)) {
+    new_var_description$colors_es <- var_description$colors_es[new_order]
+  }
+
+  new_var_description
+}
+
+
+#' Sort variable description by frequency
+#'
+#' Reorders the levels and colors in a variable description list based on
+#' the frequency of each level in the data. More frequent levels are ranked
+#' higher.
+#'
+#' @param var_description A list containing variable metadata with elements:
+#'   \itemize{
+#'     \item \code{r_variable}: Name of the variable in the dataframe
+#'     \item \code{levels}: Character vector of level names
+#'     \item \code{colors}: Named vector of colors for each level
+#'     \item \code{levels_es}: (Optional) Spanish translations of levels
+#'     \item \code{colors_es}: (Optional) Spanish-named color vector
+#'   }
+#' @param def The dataframe containing the data to analyze
+#' @param grouping_var Optional grouping variable (not used, included for
+#'   consistency with \code{sorted_by_widest_appearance})
+#'
+#' @return A modified variable description list with levels and colors reordered
+#'   by frequency. Includes a new \code{$ranked} element with the sorted levels.
+#'
+#' @export
+#' @examples
+#' \dontrun{
+#' deaths <- assign_protest_domain_levels(deaths_aug24)
+#' # Sort protest domains by total frequency
+#' pd_sorted <- sorted_by_most_frequent(
+#'   var_description = lev$protest_domain,
+#'   def = deaths
+#' )
+#' }
+sorted_by_most_frequent <- function(var_description, def, grouping_var = NULL) {
+  # Note: grouping_var parameter is not used but included for API consistency
+
+  var_name <- var_description$r_variable
+  var_description$ranked <-
+    count(def, !!sym(var_name)) %>% # frequency table for the variable in question
+    arrange(desc(n)) %>%              # ranked downward
+    pull(!!sym(var_name))      # vector of the groups
+  new_var_description <- var_description
+
+  # Get the new order based on ranked
+  new_order <- match(new_var_description$ranked, var_description$levels)
+
+  # Reorder levels
+  new_var_description$levels <- var_description$ranked
+
+  # Reorder levels_es if it exists
+  if (!is.null(var_description$levels_es)) {
+    new_var_description$levels_es <- var_description$levels_es[new_order]
+  }
+
+  # Reorder colors
+  new_var_description$colors <- var_description$colors[new_order]
+
+  # Reorder colors_es if it exists
+  if (!is.null(var_description$colors_es)) {
+    new_var_description$colors_es <- var_description$colors_es[new_order]
+  }
+
+  new_var_description
+}