In PublicMapping/dbclient:

### Setup 

## Knit environment & parameters
library(knitr)
# options for this document
GLOBALS <- params
knitr::opts_chunk$set("message" = GLOBALS$debug)
knitr::opts_chunk$set("warning" = GLOBALS$debug)
knitr::opts_chunk$set("tidy" = FALSE) # already tidyed using stylr
knitr::opts_chunk$set(autodep=TRUE)

## Libraries
library("tidyverse")
library("readxl")
library("haven")
library("magrittr")
library("gt")
library("googledrive")
library("httr")
library("fs")
library("shiny")
library("shinyjs")
library("DT")
#library("ggplotify")
library("patchwork")
#library(manipulateWidget)

#library("sf")
library("ggspatial")
library("leaflet")
library("plotly")
library("bslib")
library("thematic")

## Directories setup
GLOBALS$plan_dir  <- fs::path(GLOBALS$working_dir,"plans")
GLOBALS$checkpoint  <- fs::path(GLOBALS$working_dir,"checkpoint",ext="RData")

if (params$clean_data) {
  unlink(GLOBALS$working_dir, recursive=TRUE)
  dir.create(GLOBALS$working_dir)
   dir.create(GLOBALS$plan_dir)
} 

thematic_shiny()

```{css css-setup, echo=FALSE} @import url('https://fonts.googleapis.com/css2?family=Libre+Baskerville&display=swap'); div.main-container { max-width: 1600px !important; } body { font-family: 'Libre Baskerville', serif; } img { display:block; float:none; margin-left:auto; margin-right:auto; width:80%; text-align:center; } .caption { display:block; float:none; margin-left:auto; margin-right:auto; width:80%; text-align:center; } aside { float: right; color: blue; }

/ aside mod from tufte.css but remapped to aside element /

aside { float: right; clear: right; margin-right: -60%; width: 50%; margin-top: 0.3rem; margin-bottom: 0; font-size: 1.1rem; line-height: 1.3; vertical-align: baseline; position: relative; }

/fix for DT scrolling and header alignment/ .dataTables_wrapper{ overflow-x: auto; clear:both; }

```r
## Dblient routines
#TODO: Replace with library load when dbclient library is pushed to CRAN
try(silent=TRUE, {source("../R/dbclient.R")})
try(silent=TRUE, {source("./R/dbclient.R")})
try(silent=TRUE, {source("dbclient.R")})
.onLoad()

### Refresh plan set 
refresh_checkpoint <- function(checkpoint=GLOBALS$checkpoint) {

  # Update id list
  tmpsubfile <- fs::path(params$working_dir,"submissions",ext="xlsx")
  googledrive::drive_deauth()
  googledrive::drive_download(
    googledrive::as_id(params$submission_gdrive_uri),
    path = tmpsubfile,
    overwrite = TRUE
  )
  tmpxl <- readxl::read_excel(tmpsubfile)
  contestPlans.tb <- tmpxl %>% select(GLOBALS$submission_url_field, GLOBALS$submission_desc_field) 
  names(contestPlans.tb) <- c("url","description")
  contestPlans.tb %<>% mutate( id = str_replace(url, ".*projects/(.*)$","\\1"))
  contestPlans.tb %<>% group_by(id) %>% slice_tail(n=1) %>% ungroup() # deduplicate repeat submission

  # Retrieve new plan files
  tmpmeta <- db2meta(contestPlans.tb$id,targetdir=GLOBALS$plan_dir)
  contestPlans.tb %<>% inner_join(tmpmeta,by=c("id"="plan_id")) # this drops plans that weren't retreiveable
  contestPlans.sflist <- db2sf(contestPlans.tb$id,targetdir=GLOBALS$plan_dir)

  # Update plan scores
  contestScores.df <- map_dfr(contestPlans.sflist, function(x)
    as.data.frame(x) %>% 
      ungroup() %>% 
      mutate(properties.contiguity = properties.contiguity=="contiguous") %>%
      filter(id>0) %>%
      summarize(across(starts_with("properties"), ~ mean(.x, na.rm = TRUE),  .names = "{.col}_mn"))
  )
  names(contestScores.df) <-  str_replace(names(contestScores.df),"properties.","")
  contestPlans.tb %<>% bind_cols(contestScores.df)
  contestPlans.tb %<>% bind_cols(tibble(map=contestPlans.sflist))

  if (params$apikey!="" & options()$dbclient.pscore.apikey =="") {
        options("dbclient.pscore.apikey"=apikey)
  }

  # add unassigned score -- detect incomplete districts
  unassigned.tb <- contestPlans.tb %>%
    rowwise() %>%
    transmute(head= map %>% 
    as.data.frame() %>% 
    slice_head(n=1)) %>%
    unpack(head)

unassigned_scores.tb <- unassigned.tb %>% rowwise() %>% transmute(
  unassigned_geography=(length(geometry[[1]])>0),
  unassigned_population= sum(c_across(starts_with("properties.demographics")) > 0 ,na.rm=TRUE)>0
           )

contestPlans.tb %<>% bind_cols(unassigned_scores.tb) 

# compute  maj-min district scores -- these are missing in score results
majmin.tb <- contestPlans.tb %>% 
  select("id","map") %>% rename(planid=id) %>%
  unnest(map) %>%
  select(planid,id,starts_with("properties.demographics")) %>%
  filter(id>0) %>% 
  rowwise() %>% 
  mutate(percent_white = properties.demographics.white / properties.demographics.population,
         is_maj_min_district = percent_white <.5)  %>%
  group_by(planid) %>% 
  summarize(majMin_n=sum(is_maj_min_district),numdists=n()) %>% 
  ungroup() %>%
  rename(id=planid)

contestPlans.tb %<>% left_join(majmin.tb) 

tmpsplits.tib<-map_dfr(contestPlans.tb$id, function(x) {
  tmpblocks.tb <- db2df(x,targetdir = GLOBALS$plan_dir)[[1]]
  tmpblocks.tb %>%
    mutate(county=str_sub(BLOCKID,3,5)) %>%
    group_by(county) %>% 
    summarize(splits=length(unique(DISTRICT))-1) %>%
    ungroup() %>%
    summarise(county_split_count = sum(splits>0), county_split_sum=sum(splits))
})

contestPlans.tb %<>% bind_cols(tmpsplits.tib) 

contestPlans.tb %<>% relocate(plan_name,url,unassigned_geography,unassigned_population,numdists,contiguity_mn,majMin_n,county_split_count,county_split_count)

# Add Planscores  
  if (options()$dbclient.pscore.apikey !="") {
      tmpplanscore.df  <- generate_planscore_df(contestPlans.tb$id, targetdir=GLOBALS$plan_dir)
      contestPlans.tb %<>% left_join(tmpplanscore.df,by=c("id"="id"))
      contestPlans.tb %<>% relocate(plan_name,url,unassigned_geography,unassigned_population,numdists,contiguity_mn,majMin_n,county_split_count,county_split_count,`Efficiency Gap`,`Partisan Bias`)

  }    

  # Cleanup  & checkpoint

  save(contestPlans.tb, file=checkpoint)

} 

if (GLOBALS$refresh_data) refresh_checkpoint()

load(GLOBALS$checkpoint)

# convenience columns, sort order (affects menus)
contestPlans.tb %<>% 
  mutate(psViewURI = str_replace( planscoreURI, 
      ".*/(.*)/index.json","https://planscore.campaignlegal.org/plan.html?\\1"),
        psView=paste("<a href='",psViewURI,"' target='_ps'>",psViewURI,"</a>",sep=""),
        dbView=paste("<a href='",url,"' target='_db'>",url,"</a>",sep="")) %>%
  arrange(plan_name)

  activeids <- contestPlans.tb %>% select(`id`) %>% pull

Explore Scores

scores.tb <- contestPlans.tb %>%
  select(`id`, `plan_name`, `unassigned_geography`, `unassigned_population`, `numdists`,
         `plan_region`, `compactness_mn`, `contiguity_mn`, `county_split_sum`,
         `Partisan Bias`, `Efficiency Gap`,`majMin_n`) 

scoreVars <-setdiff( names(which(sapply(scores.tb,is.numeric))), c("numdists"))
scoreRegions <- unique(scores.tb$plan_region)



shinyApp( enableBookmarking = "url",
          options=list(
            display.mode="showcase", # NOTE: ignored in markdown environment
            height=1200
          ),
          ui = function(request) { 
            planlist_start<- contestPlans.tb$id ; names(planlist_start)<-contestPlans.tb$plan_name

            fluidPage(
                 useShinyjs(),  
              titlePanel("Compare Scores"),

              sidebarLayout(
                sidebarPanel(
                  selectInput("crit_1", "First Criteria", scoreVars),
                  selectInput("crit_2", "Second Criteria", tail(scoreVars,-1)), # TODO: dynamically remove first criteria
                  selectInput("region", "regions", scoreRegions),
                  checkboxInput("filterLegal", "Legal Plans Only", value = TRUE),
                  #   br(),
                  #    bookmarkButton()  # TODO: Debug bookmarking in notebooks see: https://github.com/rstudio/shiny/pull/1209#issuecomment-227207713 

                ),
                mainPanel(
                  tabsetPanel(type = "tabs",
                              tabPanel("Score Tradeoffs ", plotOutput("Tradeoffs",brush="plan_brush")# ,
                                      #verbatimTextOutput("info") 
                              ),
                              tabPanel("Score Distributions", plotlyOutput("Distributions")) 
                  ),
                )
              ),
              titlePanel("Plan Details"),
              sidebarLayout(

                sidebarPanel(
                  selectInput("selected_plan", "Primary plan", planlist_start),
                  actionButton('btn_d','Open in DistrictBuilder'),
                  actionButton('btn_p','Open in Plan Score'),
                  withTags({
                    br()
                    hr()
                  }),
                  conditionalPanel(
                    condition = "input.tabs == 'comparison'",
                    selectInput("comparison_plan", "Comparison plan", tail(planlist_start,-1)),
                  ),
                ),

                mainPanel(

                  tabsetPanel(type = "tabs", id="tabs",
                              tabPanel(value="single", "Plan Map", leafletOutput("map")#, textOutput("SelectedIDs") 
                              ),
                              tabPanel(value="single", "Plan Overview", tableOutput("overview")),
                              tabPanel(value="single", "Plan Districts", DTOutput("details")),
                              tabPanel(value="comparison", "Map Comparison", plotOutput("compareMap"), tableOutput("compareTable"))
                  )
                )
              ),
            )
          },
          server = function(input, output, session) {
            # update criteria pulldown 2 
            observe({
              x <- input$crit_1
              cur_c2 <- input$crit_2

              y <- setdiff(scoreVars,x)

              # if current selection is invalidated, change it
              if (! cur_c2 %in% y) {
                cur_c2 <- head(y,1)
              }

              # Can also set the label and select items
              updateSelectInput(session, "crit_2",
                                choices = y,
                                selected = cur_c2
              )
            })

            # Bookmarking
            observe({
              # Trigger this observer every time an input changes
              reactiveValuesToList(input)
              session$doBookmark()
            })
            onBookmarked(function(url) {
              updateQueryString(url)
            })

            # update current table based on selected regions
            filtered.tb <- reactive({ 
              if (input$filterLegal) {
                out <- scores.tb %>% filter(unassigned_geography==FALSE, 
                                            unassigned_geography == FALSE,
                                            plan_region==input$region)
              } else {
                out <- scores.tb %>% filter(plan_region==input$region)
              }

              activeidsl <- out %>% select(`id`) %>% pull

              assign("activeids", activeidsl, envir = .GlobalEnv)

              out
            })

            # Experimental: monitor active selections
            activeidsR <- reactive(activeids)

            output$Tradeoffs <- renderPlot({

              #TODO: Note the approach to workaround lazy evaluation and brush_point failure
              # research a better way
              plot.tb <- filtered.tb() 
              plot.tb$crit_1 <- plot.tb[[input$crit_1]]
              plot.tb$crit_2 <- plot.tb[[input$crit_2]]

              p1 <- plot.tb %>% 
                #ggplot(aes(x=.data[[input$crit_1]], y= .data[[input$crit_2]],  label=plan_name)) +
               ggplot(aes(x= crit_1, y= crit_2,  label=plan_name)) +

                geom_point() +               
                geom_smooth(aes(alpha=.01)) +
                geom_text(aes(alpha=.01)) +
                facet_wrap(nrow=1,facets=vars(numdists), labeller="label_both")+
                coord_flip() +
                guides(alpha="none") +
                labs(size="",alpha="",x=input$crit_1,y=input$crit_2)

              curplot<<-p1
              p1
            })

            # TODO:  Plotly selection event handling 
            # output$Selection <- renderText({
            #   pldata <- event_data("plotly_selected", source = "trade")
            #   if (is.null(pldata)) return(NULL)
            #   paste(out,names(pldata))
            # })

            output$SelectedIDs <- renderText({

              paste("filtered.tb", dim(filtered.tb())[1],
                    "activeidsR", length(activeidsR())
              )

            })

            output$Distributions <- renderPlotly({
              p1 <- filtered.tb() %>% 
                ggplot(aes(y=.data[[input$crit_1]])) +  # NOTE: .data workaround for tidy evaluation in shiny context
                geom_histogram() + 
                facet_wrap(nrow=1,facets=vars(numdists), labeller="label_both")+
                coord_flip() +
                guides(alpha="none") +
                labs(x="",alpha="") 
              p2 <- filtered.tb() %>% 
                ggplot(aes(y=.data[[input$crit_2]])) +
                geom_histogram() + 
                facet_wrap(nrow=1,facets=vars(numdists), labeller="label_both")+
                coord_flip() +
                guides(alpha="none") +
                labs(x="",alpha="") 

              # TODO:   abstract patchwork/subplot
              # TODO: density plot -- geom_density chokes ggplotify
              # p1/p2
              subplot(ggplotly(p1,source="dist2"),ggplotly(p2,source="dist2"),nrows=2)
            })


            ### Second Panel

            # update planlist pulldown 1
            planlist <- reactive ({ 
              sid = selected_ids()
              x <- filtered.tb() %>% select(id,plan_name)
              y <- x$id; names(y)<-x$plan_name
              if(length(sid)>0) {
                y<- y[which(y %in% sid)] 
              } 
              y
            })

            observe({
              y <- planlist()

              updateSelectInput(session, "selected_plan",
                                choices = y,
                                selected = head(y, 1)
              )
            })

            # update planlist pulldown 2 
            observe({
              x <- input$selected_plan

              y <- planlist()
              y <- y[which(y!=x)] #NOTE: setdiff removes names from list... avoid

              updateSelectInput(session, "comparison_plan",
                                choices = y,
                                selected = head(y, 1)
              )
            })

             selected_ids <- reactive ({

              pb <- input$plan_brush
              if (is.null(pb)) return(list())

              plot.tb <- filtered.tb() 
              plot.tb["crit_1"] <- plot.tb[[input$crit_1]]
              plot.tb["crit_2"] <- plot.tb[[input$crit_2]]
              bpi <- brushedPoints(df=plot.tb,pb,xvar = input$crit1_1,yvar=input$crit_2)
              plot.tb %<>% select(id,crit_1,crit_2)

              #TODO: Debug brushed points -- this is a workaround -- wouldn't work for multiple panels

              sid<- plot.tb %>% rowwise() %>% filter( crit_1 <= pb$ymax, crit_1 >= pb$ymin,
                                  crit_2 <= pb$xmax, crit_2 >= pb$xmin ) %>% pull(id)

              sid
            })


            # precompute for efficiency across tabs
            curPlan <- reactive(contestPlans.tb %>% filter(id==input$selected_plan))
            curMap <-  reactive(curPlan()[[1,"map"]][[1]])
            compPlan <- reactive({contestPlans.tb %>% filter(id==input$comparison_plan)})
            compMap <-  reactive(compPlan()[[1,"map"]][[1]])

            #TODO: error presentation is a hack -- should figure out how to change output type...
            curPS <-   reactive({
              out <- curPlan()[[1,"districtScoreTable"]][[1]]
              if (is.null(out)) {out = tibble(warning="SCORES MISSING (Plan may be incomplete or corrupt)")}
              out
            }) 

            # button handler
            observe({
              curPlan()

              onclick("btn_p", runjs(paste(sep="", "window.open('", curPlan()["psViewURI"], "')"))) 
              onclick("btn_d", runjs(paste(sep="", "window.open('", curPlan()["url"], "')"))) 
            })
            # # ggplotly based - not supported
            # output$map <- renderPlotly({
            #    p<- curMap() %>% ggplot() + geom_sf()
            #    p %>% ggplotly() # NOTE - geom_sf not supported in ggplotly
            #   })
            # 

            output$info <- renderText({

              pb <- input$plan_brush
              xy_range_str <- function(e) {
                if(is.null(e)) return("NULL\n")
                paste0("xmin=", round(e$xmin, 1), " xmax=", round(e$xmax, 1), 
                       " ymin=", round(e$ymin, 1), " ymax=", round(e$ymax, 1))
              }

              paste0(
                "brush: ", xy_range_str(pb),
                "selected: ", selected_ids(),
                collapse=","
              )
            })

            output$map <- renderLeaflet({
              p<- curMap() %>% 
                leaflet() %>% 
                addTiles() %>%
                addPolygons(color = "green")
              p
            })

            output$overview <- renderTable({
              curPlan() %>% select(plan_name,plan_creator,description) 
            })

            output$details <- renderDT({
              curPS()
            })

            output$compareMap <- ({
              renderPlot({
                p1<- curMap() %>% 
                  ggplot(aes(color= curPlan()$plan_name )) +
                  geom_sf()+
                  geom_sf(data=compMap(),aes(color=compPlan()$plan_name,alpha=0)) +
                  guides(alpha="none") + labs(color="Plan")
                p1
              })
            })

            output$compareTable <- ({
              presTB <- reactive({
                compTb <- bind_rows(curPlan(),compPlan())  %>% select(where(is.numeric))
                pdiff<-  apply(compTb,2,function(x)(x[1]-x[2]))  
                tmpo <- bind_rows(compTb,pdiff)
                pname <- c(curPlan()$plan_name,compPlan()$plan_name,"Difference")
                tmpo <- bind_cols(planname=pname,tmpo)
                tmpo
              })

              renderTable({
                presTB()  %>%
                  rownames_to_column() %>%  
                  mutate(across(everything(),as.character)) %>%
                  pivot_longer(-rowname) %>% 
                  pivot_wider(names_from=rowname, values_from=value) 
              })

            })

          }
)

All Scores - Details & Download

### Explore set of plans

pscore.tb <- reactive(contestPlans.tb %>% select(-map, -districtScoreTable))

# Score table
# TODO: Auto size height to avoid vertical scrolling
renderDT({
   pscore.tb() %>% 
  select(-file_src, -planscoreURI, -description) %>%
   relocate(plan_name, unassigned_geography, unassigned_population, numdists, contiguity_mn, majMin_n, county_split_count, county_split_sum, dbView, psView) %>%
  datatable(class = "cell-border stripe; hover",
            caption = "",
            editable=FALSE,
            escape=FALSE,
            selection=list(mode="single",selected=1),
            filter="top",  
            rownames=FALSE,
            extensions = list(
                      "ColReorder" = list(TRUE),
                      "Buttons" = NULL
                      ),
           options = list(
                dom = 'RrlBftpi',
                autoWidth=TRUE,
                #bAutoWidth=FALSE,
                pageLength=5,
                scrollX=FALSE,
                lengthMenu = list(c(5, 50, -1), c('5', '20', 'All')),
                buttons =
                  list(
                    'copy',
                    'print',
                    list(
                      extend = 'collection',
                      buttons = c('csv', 'excel', 'pdf'),
                      text = 'Download'
                    ),
                   I('colvis')
                  )
              )
    )  %>% 
 formatStyle(
    'unassigned_geography',
     backgroundColor = styleEqual(c(TRUE), c('lightpink') )
  ) %>%
  formatStyle(
    'unassigned_population',
     backgroundColor = styleEqual(c(TRUE), c('lightpink') )
  ) %>%
  formatStyle(
    'contiguity_mn',
     backgroundColor = styleEqual(c(1), c('lightgreen'),default='orange' )
  )


  })

#TODO: Set specified plan with row tab-selection -- complication is that table ID is autogenerated
## 
# rmarkdown::render_delayed({  
#    renderPrint({
#     tn <- names(input)
#     ts<- tn[which(str_detect(tn,"rows_selected"))]
#     paste(ts,input)
#    })
#  })

PublicMapping/dbclient documentation built on Aug. 27, 2022, 9:55 a.m.