Update plots

ki-tools · Apr 28, 2022 · 9674441 · 9674441
1 parent 6376f2e
commit 9674441
Show file tree

Hide file tree

Showing 9 changed files with 203 additions and 36 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -1,6 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
-S3method(print,idhs_map_vis)
+S3method(print,idhs_browsable)
 export(calc_rates)
 export(geo_scatter_vis)
 export(preprocess_geo)
@@ -46,7 +46,6 @@ importFrom(plotly,plot_ly)
 importFrom(plotly,subplot)
 importFrom(rmapshaper,ms_simplify)
 importFrom(sf,st_bbox)
-importFrom(sf,st_sfc)
 importFrom(tidyr,nest)
 importFrom(utils,download.file)
 importFrom(viridisLite,viridis)
diff --git a/R/misc.R b/R/misc.R
@@ -8,15 +8,35 @@ view_var_descs <- function(x, include_geo = FALSE) {
   check_ipums_data(x, "x")
 
   descs <- sapply(x, function(x) attr(x, "var_desc"))
+  lbls <- sapply(x, function(x) attr(x, "label"))
   descs <- dplyr::tibble(
     name = names(descs),
+    label = unname(lbls),
     desc = unname(descs)
   )
   if (!include_geo) {
     descs <- dplyr::filter(descs, !grepl("^geo_", .data$name))
+    descs <- dplyr::filter(descs, !grepl("^geoalt_", .data$name))
   }
 
-  DT::datatable(descs, options = list(paging = FALSE))
+  dt <- DT::datatable(descs, width = "100%", options = list(paging = FALSE))
+
+  tags <- htmltools::tags
+
+  res <- htmltools::tagList(
+    tags$head(tags$style("
+      body {
+        margin: 0;
+        padding: 30px;
+        font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, Oxygen, Ubuntu, Cantarell, 'Open Sans', 'Helvetica Neue', sans-serif
+      }
+    ")),
+    dt
+  )
+
+  class(res) <- c("idhs_browsable", class(res))
+
+  res
 }
 
 get_tkn <- function() {

diff --git a/R/vis_geo.R b/R/vis_geo.R
@@ -163,26 +163,27 @@ build_map <- function(p, bins, leglbl, cols, title, bboxstr, height, width) {
             e.features.length > 0 &&
             e.features[0].properties.country_region !== hoveredId
           ) {
-            Plotly.restyle(scatter, {'line': {'color': 'darkgray'}}, [])
+            // Plotly.restyle(scatter, {'line': {'color': 'darkgray'}}, [])
             hoveredId = e.features[0].properties.country_region;
             curmap.setPaintProperty(
               'map-lines',
               'line-opacity',
               ['match', ['get', 'country_region'], hoveredId, 1, 0.1]
             );
+
             curmap.setPaintProperty(
               'map-lines',
               'line-width',
               ['match', ['get', 'country_region'], hoveredId, 3, 1]
             );
-            var traceidx = scatter.data.findIndex(obj => {
-              return obj.name === hoveredId;
-            });
-            if (traceidx > -1) {
-              // console.log('restyling hover...');
-              // Plotly.addTraces(scatterplot, [{x: [2010], y: [20], mode: 'markers', marker: {symbol: 6, size: 12}, xaxis: 'x', yaxis: 'y'}])
-              Plotly.restyle(scatter, {'line': {'color': 'blue'}}, [traceidx])
-            }
+            // var traceidx = scatter.data.findIndex(obj => {
+            //   return obj.name === hoveredId;
+            // });
+            // if (traceidx > -1) {
+            //   console.log('restyling hover...');
+            //   Plotly.addTraces(scatterplot, [{x: [2010], y: [20], mode: 'markers', marker: {symbol: 6, size: 12}, xaxis: 'x', yaxis: 'y'}])
+            //   Plotly.restyle(scatter, {'line': {'color': 'blue'}}, [traceidx])
+            // }
           }
         };
 
@@ -199,7 +200,7 @@ build_map <- function(p, bins, leglbl, cols, title, bboxstr, height, width) {
           );
 
           // console.log('restyling unhover...');
-          Plotly.restyle(scatter, {'line': {'color': 'darkgray'}}, [])
+          // Plotly.restyle(scatter, {'line': {'color': 'darkgray'}}, [])
           hoveredId = null;
         };
 
@@ -210,7 +211,7 @@ build_map <- function(p, bins, leglbl, cols, title, bboxstr, height, width) {
 
         scatterplot.on('plotly_hover', function(d) {
           // console.log('restyling plotly hover...')
-          Plotly.restyle(scatterplot, {'line': {'color': 'blue'}}, [d.points[0].curveNumber])
+          // Plotly.restyle(scatterplot, {'line': {'color': 'blue'}}, [d.points[0].curveNumber])
           var hoveredId = d.points[0].data.name;
           var country = hoveredId.split('___')[0];
           if (bboxes && bboxes[country]) {
@@ -243,7 +244,7 @@ build_map <- function(p, bins, leglbl, cols, title, bboxstr, height, width) {
             1
           );
           // console.log('restyling plotly unhover...')
-          Plotly.restyle(scatterplot, {'line': {'color': 'darkgray'}}, [d.points[0].curveNumber]);
+          // Plotly.restyle(scatterplot, {'line': {'color': 'darkgray'}}, [d.points[0].curveNumber]);
         });
       }
     ")),
@@ -256,17 +257,22 @@ build_map <- function(p, bins, leglbl, cols, title, bboxstr, height, width) {
         width: fit-content;
         font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, Oxygen, Ubuntu, Cantarell, 'Open Sans', 'Helvetica Neue', sans-serif
       }
-      .title {
+      .geo-title {
         position: absolute;
         font-size: 16px;
         top: 0;
-        left: 0;
+        right: 10px;
+        font-style: italic;
+        padding: 4px;
+        color: #565656;
+        font-weight: 300;
+        background: rgba(255, 255, 255, 0.7);
       }
       .legend-container {
         position: absolute;
         display: flex;
         flex-direction: column;
-        top: 10px;
+        top: 26px;
         right: 10px;
         background: rgba(255, 255, 255, 0.7);
       }
@@ -288,7 +294,7 @@ build_map <- function(p, bins, leglbl, cols, title, bboxstr, height, width) {
       class = "geo-container",
       style = paste0("width: ", width, "; height: ", height, ";"),
       p,
-      tags$div(class = "title", title),
+      tags$div(class = "geo-title", title),
       tags$div(class = "legend-container",
         lapply(seq_along(leglbl), function(ii) {
           tags$div(class = "legend-entry",
@@ -306,13 +312,13 @@ build_map <- function(p, bins, leglbl, cols, title, bboxstr, height, width) {
     )
   )
 
-  class(res) <- c("idhs_map_vis", class(res))
+  class(res) <- c("idhs_browsable", class(res))
 
   res
 }
 
 #' @export
-print.idhs_map_vis <- function(x, ...) {
-  class(x) <- setdiff(class(x), "idhs_map_vis")
+print.idhs_browsable <- function(x, ...) {
+  class(x) <- setdiff(class(x), "idhs_browsable")
   print(htmltools::browsable(x))
 }
diff --git a/R/vis_geo_scatter.R b/R/vis_geo_scatter.R
@@ -5,12 +5,18 @@
 #' @param bins TODO
 #' @importFrom htmltools browsable
 #' @export
-geo_scatter_vis <- function(rates, title, geo_dir, bins = NULL) {
-  p1 <- scatter_vis_all(rates)
+geo_scatter_vis <- function(
+  rates, title, subtitle, ylab, geo_title, geo_dir, bins = NULL
+) {
+  p1 <- scatter_vis_all(rates,
+    title = title,
+    subtitle = subtitle,
+    ylab = ylab
+  )
 
   p2 <- geo_vis_all(
     rates = rates,
-    title = title,
+    title = geo_title,
     geo_dir = geo_dir,
     bins = bins,
     width = "40vw"
@@ -30,5 +36,7 @@ geo_scatter_vis <- function(rates, title, geo_dir, bins = NULL) {
     )
   )
 
-  htmltools::browsable(res)
+  class(res) <- c("idhs_browsable", class(res))
+
+  res
 }
diff --git a/R/vis_scatter.R b/R/vis_scatter.R
@@ -13,7 +13,9 @@ get_ci <- function(x, n) {
 #' @importFrom forcats fct_reorder
 #' @importFrom tidyr nest
 #' @export
-scatter_vis_all <- function(rates) {
+scatter_vis_all <- function(
+  rates, title = "scatterplot", subtitle = "", ylab = ""
+) {
   alldat <- dplyr::bind_rows(
     lapply(rates, function(x) x$yrregstats)) %>%
     dplyr::mutate(
@@ -123,10 +125,13 @@ scatter_vis_all <- function(rates) {
   annotations <- lapply(seq_len(nrow(pdat)), function(ii) {
     cur_col <- (ii - 1) %% ncols + 1
     cur_row <- ceiling(ii / ncols)
+    ctry_txt <- as.character(pdat$country[ii])
+    if (ctry_txt == "Congo Democratic Republic")
+      ctry_txt <- "DR Congo"
     list(
       x = (1 / ncols) / 2 + (cur_col - 1) * (1 / ncols),
       y = 1 - (cur_row - 1) * (1 / nrows),
-      text = as.character(pdat$country[ii]),
+      text = ctry_txt,
       xref = "paper",
       yref = "paper",
       xanchor = "center",
@@ -155,7 +160,7 @@ scatter_vis_all <- function(rates) {
       yshift = -19
     ),
     list(
-      text = "STI Rate",
+      text = ylab,
       x = 0,
       y = 0.5,
       showarrow = FALSE,
@@ -182,5 +187,48 @@ scatter_vis_all <- function(rates) {
 
   res$sizingPolicy$defaultHeight <- "100%"
 
-  res
+  tags <- htmltools::tags
+
+  res2 <- htmltools::tagList(
+    tags$head(tags$style("
+      body {
+        margin: 0;
+        padding: 0;
+        font-family: -apple-system, BlinkMacSystemFont, 'Segoe UI', Roboto, Oxygen, Ubuntu, Cantarell, 'Open Sans', 'Helvetica Neue', sans-serif;
+      }
+      .scatter-container {
+        display: flex;
+        flex-direction: column;
+        height: 100vh;
+      }
+      .scatter-title {
+        font-size: 25px;
+        padding-top: 5px;
+        padding-bottom: 1px;
+        padding-left: 20px;
+      }
+      .scatter-subtitle {
+        font-size: 14px;
+        padding-top: 1px;
+        padding-bottom: 5px;
+        padding-left: 20px;
+      }
+    ")),
+    tags$div(
+      class = "scatter-container",
+      tags$div(
+        class = "scatter-title",
+        title
+      ),
+      tags$div(
+        class = "scatter-subtitle",
+        subtitle
+      ),
+      res
+    )
+  )
+
+  class(res2) <- c("idhs_browsable", class(res2))
+
+  res2
 }
diff --git a/README.md b/README.md
@@ -1 +1,74 @@
 # idhs
+
+Experimental R package for working with the IPUMS-processed DHS data (links and citations to come).
+
+An example visualization [here](https://ki-tools.github.io/38B-vis/sti_women/).
+
+## Install
+
+```r
+# install.packages("remotes")
+remotes::install_github("ki-tools/idhs")
+```
+
+## Examples
+
+```r
+library(idhs)
+
+# preprocess an IPUMS extract
+dd <- preprocess_ipums(
+  input_xml = "ext-data/idhs/extract2/idhs_0000.xml",
+  output_file = "ext-data/idhs/extract1/dd.rds"
+)
+
+# pull all shapefiles associated with data in the extract
+preprocess_geo(dd, output_dir = "ext-data/idhs/geo/")
+
+# html page showing variable names and their descriptions
+view_var_descs(dd)
+view_var_descs(dd, include_geo = TRUE)
+
+# ---------- get regional yearly STI prevalence ---------- #
+
+# numerator is stianyr (had STI in last 12 months) = "Yes"
+attributes(dd$stianyr)[c("labels", "label")]
+# denominator is all responses except sexactiv4wk = "never had intercourse"
+attributes(dd$sexactiv4wk)[c("labels", "label")]
+
+sti_rates <- calc_rates(dd,
+  geo_dir = "ext-data/idhs/geo/",
+  num_var = "stianyr",
+  num_cond = 1,
+  denom_var = "sexactiv4wk",
+  denom_cond = c(1:9)
+)
+
+# -------------------- visualizations -------------------- #
+
+# individual scatter
+scatter_vis_all(
+  sti_rates,
+  title = "Women reporting an STI in the 12 months preceding the survey",
+  subtitle = "Among women who ever had sexual intercourse, by country subregion",
+  ylab = "Percentage of women reporting an STI"
+)
+
+# individual geo
+geo_vis_all(sti_rates,
+  title = "Percent STI for latest country survey",
+  geo_dir = "ext-data/idhs/geo/",
+  bins = c(0, 2, 4, 6, 10, 15, 35)
+)
+
+# joint
+geo_scatter_vis(
+  sti_rates,
+  title = "Women reporting an STI in the 12 months preceding the survey",
+  subtitle = "Among women who ever had sexual intercourse, by country subregion (hover a point to see percentage and 95% CI)",
+  ylab = "Percentage of women reporting an STI",
+  geo_title = "Percent STI for latest country survey",
+  geo_dir = "ext-data/idhs/geo/",
+  bins = c(0, 2, 4, 6, 10, 15, 35)
+)
+```
diff --git a/man/geo_scatter_vis.Rd b/man/geo_scatter_vis.Rd
diff --git a/man/scatter_vis_all.Rd b/man/scatter_vis_all.Rd