-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathapp.R
924 lines (794 loc) · 55 KB
/
app.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
# Title: app.R
# Author: Liam Tay Kearney
# Date: December 2022
# Version: 0.4
# Notes: nyc-transit Shiny app
# Url: https://ltk2118.shinyapps.io/nyc-transit/
library(dplyr)
library(tidyr)
library(magrittr)
library(shiny)
library(shinyWidgets)
library(plotly)
library(DT)
library(tmap)
library(leaflet)
library(leaflet.extras)
library(sf)
source("setup.R")
# -------------------------- UI ------------------------------
ui <- shinyUI(fluidPage(
## THEMING --------------------
theme = shinythemes::shinytheme("yeti"),
#setBackgroundImage(src = ""),
div(style = "padding: 1px 0px; width: '100%'",
titlePanel(
title = "",
windowTitle = "A New Measure of Public Transit Accessibility"
)
),
navbarPage(
title = div(span("A New Measure of Public Transit Accessibility",
style = "position: relative; top: 50%; transform: translateY(-50%);")),
## TAB 1 - DATA AND METHODS -----------------------------
tabPanel("Introduction",
tags$div(
tags$h3("Overview"),
tags$p(HTML("This app presents interactive data on a new measure of <b>public transit accessibility to public services</b> calculated using a route optimization engine. The specific use case presented here is for public transit accessibility
to higher education institutions from Brooklyn, using Google's <a href = 'https://developers.google.com/maps/documentation/directions/overview'>Directions API</a>. The methods utilized here, however, are easily transferable to other use
cases (e.g. hospitals, aged-care, and community services) and alternative route optimizers (e.g. Open Street Maps (OSM), GraphHopper, and Radar). The data here are generated by requesting route information on approximately 500,000 individual
trips between block group centroids and higher education institutions.")),
tags$p(HTML("The results are visualized interactively in the <b>Accessibility Measures</b> tab, which takes user inputs on the types of institutions of interest, and constraints on
the duration and nature of the routes (trips). The <b>Analytics</b> tab provides functionality for interactive comparisons of the accessibility measures with cross-cutting variables of interest taken from the American Community Survey (ACS).")),
tags$p(HTML("All data tables and visualizations are <a href = 'https://shiny.rstudio.com/articles/understanding-reactivity.html#:~:text=Reactivity%20creates%20the%20illusion%20that,information%20from%20input%20to%20output.'>
reactive</a> and constructed purposefully to facilitate customizable download and rapid adaptation to external use cases by researchers and policymakers. This is especially important since the notion of accessibility is context-dependent.
The purpose of this app is thus threefold: to showcase a new approach to measuring transit accessibility in the context of higher education institutions, to provide a tool for interactive exploratory work, and to share that data so others may use it in a meaningful way for further analysis.")),
tags$h6(""),
tags$h3("Background"),
tags$p(HTML("The concept of accessibility is difficult to define but critically important to analysis of public transportation issues.
The use of quantitative GIS tools to measure and analyze public transportation accessibility was popularized by <a href = 'https://www.tandfonline.com/doi/abs/10.1080/136588100240976'>O'Sullivan et al. (2000)</a>,
who lay out a technique for using timetable and street network data to calculate 'isochrones' - lines of equal travel time.
<a href = 'https://onlinelibrary.wiley.com/doi/abs/10.1111/j.1467-9671.2004.00167.x'>Liu & Zhu (2004)</a> subsequently developed an integrated GIS framework to measure accessibility and travel impedance combining a range transportation options.
Since then, a range of tools have been developed which provide real-time route optimization over entire public transportation networks,
including the Google Maps Distance Matrix API (a paid service) and the OpenStreetMap Routing Machine (ORSM) API (a free service).
These have opened new possibilities for empirical analysis of public transport accessibility.")),
tags$p(HTML("Though some authors, such as <a href = 'https://www.sciencedirect.com/science/article/abs/pii/S0966692316303453'>Moreno-Monroy et. al (2018)</a>, have used these tools to calculate travel times, none have done so in a manner that is consistent, open-source, interactive and scalable, and
most do not concentrate on public transit specifically. None have applied these techniques to study the relationship between public transit accessibility and higher education access.")),
tags$p(HTML("Such study is neglected but important - <a href = 'https://www.tandfonline.com/doi/abs/10.1080/00221546.2021.1940054'>Dache (2021)</a> demonstrates that public transportation access and quality is a factor influencing choices to pursue higher education, and may impact longer-term education outcomes.
<a href = 'https://www.sciencedirect.com/science/article/pii/S0966692310001523?casa_token=Oz_9F5bMzF8AAAAA:2Gr2sHHoNg4D9ahup2n2G9VtuhtOMhKWNMJD3za-nbhX6YZBk86nOE4h8_wLSpdbPJ0sSAcg'>Kenyon (2011)</a> shows that having transport difficulties negatively impacts students, reducing their participation in formal and informal instruction.
Kenyon also notes that university-wide participation strategies barely recognize at the institutional level that transport can be a barrier to access and achievement
in higher education. As such, one of the goals of this project is generate further interest in, and policy debate surrounding, the public transportation-higher education nexus.")),
tags$h6(""),
tags$h3("Methodology"),
tags$p(HTML("Route data were collected for communities across Brooklyn (Kings County) by Census block group boundaries. Brooklyn is chosen since it is the most populous borough and has large areas relatively
<a href = 'https://pedestrianobservations.com/2022/06/25/public-transportation-in-the-southeastern-margin-of-brooklyn/'>disconnected</a> from public transit.
and modes are determined for peak morning and evening commutes between each of 2066 origins (Kings County 2010 census block group centroids) and 126 destinations (IPEDS degree-granting
tertiary institutions, excluding faith-based institutions, that maintained an enrolment of at least 200 students in 2021).")),
tags$p(HTML("For each origin-destination pair, route information is collected in the
morning and the evening, which enables a simple average to be calculated, thereby reducing the scope for measurement error. Moreover, for morning trips, desired arrival time is set (9:00 AM), and for evening trips,
a desired departure time (5:00 PM), to align with the reality of taking public transit to and from tertiary institutions. The requests were made for two randomly chosen weekdays in December that are not public
holidays. Travel time is calculated as the time difference between the actual departure time at the origin and the actual arrival time at the destination, so includes time spent waiting and walking.")),
tags$p(HTML("Python code to execute API requests in batches compliant with Google's restrictions is made available in a public <a href = 'https://github.com/ltk2118/nyc-transit'><b>Github repository</b></a>, but requires an API key to send requests.
Note that the Google Directions API is a paid service, but other route optimizers, including OSM, are free. Pre-processing and post-processing code (in R) to replicate the entire
analysis is also provided in the Github repo, along with the code and cleaned data used to build this application. After post-processing (cleaning), the data are stored in four reactive dataframes containing information
at the school, block group, trip and leg levels respectively.")),
tags$p(HTML("The final measure of accessibility is derived by computing the number of schools (or, the number of slots, i.e. schools weighted by enrolments) accessible to each block group in Brooklyn under different institutional and trip constraints.")),
tags$h6(""),
tags$h3("Scope and limitations"),
tags$p(HTML("This application is intended to be a starting point for researchers and policymakers interested in the public transit-higher education nexus to conduct basic exploratory analysis and generate customized data downloads in pursuit of their own research goals. More broadly,
it intends to showcase how the quantitative techniques used to measure accessibility can be applied in the study of other contexts outside of higher education. These twin goals are both a strength and limitation - greater tailoring to the higher education context enhances the application's
value in that domain, but makes it more difficult to envisage use cases outside of it. I am also limited by the sheer size of the data (some variables returned by the Directions API are not presented here). Applying the technique to a broader geographic area, or a more granular
spatial unit of analysis, would require enhanced server-side processing capacity.")),
tags$h6(""),
tags$h3("Credits"),
tags$p(HTML("Many thanks to my advisor and mentor Professor <b>Harold Stolper</b>, for his wisdom and constant support during my time at Columbia.
Thank you also to Professors Elena Krumova and Greg Eirich for their teaching and mentorship throughout this process.")),
tags$br(),
tags$h6(HTML("Maintained by <a href = 'https://ltk2118.github.io/home/'><b>Liam Tay Kearney</b></a> ([email protected])
Please feel free to reach out with questions/comments/concerns.")),
tags$br(),
tags$br())),
tabPanel("Usage instructions",
tags$div(
tags$h2("How to use this app"),
tags$p(HTML("For an interactive walkthrough, please consult this <a href = 'https://youtu.be/GceUhpzT5hM'><b>explainer video</b></a> which goes through the application's functionality in more detail.
Watching the video is strongly recommended.")),
tags$p(HTML("Users may begin using the app by following these steps:")),
tags$ol(
tags$li(HTML("<b>Navigate to the Accessibility Measures tab, and click on the <u>UPDATE</u> button to load visualizations using default inputs</b>")),
tags$ul(
tags$li(HTML("The left sidebar enables the user to filter based on a variety of institutional criteria (allowable combinations of selections update adaptively to avoid conflicts)")),
tags$li(HTML("The default measure of accessibility displayed in the maps and tables is the <em>number of schools accessible</em> for any given block group.")),
tags$li(HTML("The user can toggle a switch in the left sidebar <u>Use enrolments (slots)</u> to convert the measure into the number of enrolments or 'slots' accessible, which is akin to weighting schools by their size (number of students enrolled).")),
tags$li(HTML("The left sidebar also enables the user to filter based on trip criteria, including whether data should be displayed for morning trips, evening trips, or an average of both; the time limit (cutoff) for trips,
and the maximum number of transfers allowed.")),
tags$li(HTML("These allow for users to customize the data and visualizations to their specific conceptualization of accessibility, and the subset of schools of primary interest."))
),
tags$br(),
tags$li(HTML("<b>Explore the visualizations in this tab, including the maps, plots and tables</b>")),
tags$ul(
tags$li(HTML("The maps can be modified to load different basemaps, and MTA lines and schools to be loaded in separate layers. The schools displayed are reactive to the user inputs.")),
tags$li(HTML("Block groups, MTA lines and schools display rudimentary tooltip information on hover, and detailed information on click.")),
tags$li(HTML("The maps can reset to their original zoom, and places can be searched interactively with the OSM geocoder.")),
tags$li(HTML("The plots below show information about the journeys taken, including the most frequently used routes and the agencies/authorities responsible for operating
those routes, which are likely of interest to policymakers.")),
tags$li(HTML("The data tables below contain all the underlying data and are made available for download - they can also be interactively searched, filtered and scrolled in the UI."))
),
tags$br(),
tags$li(HTML("<b>Navigate to the Analytics tab, select desired census data and click on the <u>GENERATE</u> button to load the comparative visualizations</b>")),
tags$ul(
tags$li(HTML("To select the census data, first choose a <u>concept</u> and then select the desired variable.")),
tags$li(HTML("Census data may be converted to a percent of block group population using the switch in the left sidebar.")),
tags$li(HTML("The map on the left displays census data, while the map on the right replicates the accessibility measures from the previous tab.")),
tags$li(HTML("The scatterplot plots the census data against the accessibility measure, with each dot representing one block group in Brooklyn.")),
tags$li(HTML("The data tables below contain the joined accessibility and census data, and made available for download and interactively exploration in the UI.")),
tags$li(HTML("To make updates to the school and trip filters, return to the <b>Accessibility Measures</b> tab, make the desired changes, and click the <u>UPDATE</u> button. Then
return to the <b>Analytics</b> and click on <u>GENERATE</u> again.")),
),
),
tags$h6(HTML("Please note: due to the large size of the dataset, performance and memory issues might occasionally emerge on the server end. These can typically be solved by refreshing the visualizations using the <u>UPDATE</u>
and <u>GENERATE</u> buttons, but may require the app to be reloaded entirely from the browser. Patience is a virtue, especially when attempting to
download trip or leg-level data, which may contain several million rows.")),
tags$p(HTML("In case of confusion with respect to data and variables, please consult the <b>Data Dictionaries</b> tab.")),
tags$h6(""),
tags$br()
)
),
## TAB 2 - ACCESSIBILITY MEASURES ----------------------------------
tabPanel("Accessibility Measures",
sidebarLayout(
sidebarPanel(width = 3,
### SIDEBAR INPUTS ----------------------------
HTML("<font color= 'Black', size = 3><b><u>Institution filters</u></b></font>"),
tags$br(),
tags$br(),
pickerInput(inputId = "select_size",
label = "Size",
choices = choices_size,
options = list(`actions-box` = TRUE),
selected = choices_size,
multiple = T),
pickerInput(inputId = "select_sector",
label = "Sector",
choices = choices_sector,
options = list(`actions-box` = TRUE),
selected = choices_sector,
multiple = T),
pickerInput(inputId = "select_degree_level",
label = "Degree Level",
choices = choices_degree_level,
options = list(`actions-box` = TRUE),
selected = choices_degree_level,
multiple = T),
pickerInput(inputId = "select_degree_types",
label = "Degree Types",
choices = choices_degree_types,
options = list(`actions-box` = TRUE),
selected = choices_degree_types,
multiple = T),
uiOutput("carnegie"),
materialSwitch(inputId = "switch_slots",
label = "Use enrolments (slots)", status = "info"),
tags$br(),
HTML("<font color='Black', size = 3><b><u>Trip filters</u></b></font>"),
tags$br(),
tags$br(),
selectInput(inputId = "select_run",
label = "Trip AM/PM/Both",
choices = choices_run,
selected = "Both",
multiple = F),
setSliderColor(c("Black", "Black"), c(1, 2)),
sliderInput(inputId = "slider_cutoff",
label = "Time cutoff for trips (mins)",
min = 15,
max = 100,
value = 60,
step = 5),
sliderInput(inputId = "slider_transfers",
label = "Maximum transfers",
min = 1,
max = 5,
ticks = F,
value = 5,
step = 1),
tags$br(),
actionButton(inputId = "action_update",
label = "UPDATE",
width = "100%",
style="color: #fff; background-color: #D30000; border-color: '#D30000'"),
tags$br(),
tags$br(),
textOutput("school_warning_1"),
),
### MAIN PANEL OUTPUTS ----------------------------
mainPanel(width = 9,
fluidRow(
column(10,
h3("School accessibility"),
h5("Schools or slots accessible by Brooklyn block group"),
leafletOutput("map2"),
tags$br()
)
),
fluidRow(
column(5,
h3("Most frequent transit lines"),
h5("Percent of journey legs"),
plotlyOutput("leg_lines"),
tags$br()),
column(5,
h3("Agencies responsible"),
h5("Percent of journey legs"),
plotlyOutput("leg_agency"))
),
fluidRow(
column(10,
h3("Reactive Data Tables"),
h5("For more information, see the Data Dictionaries."),
tags$br(),
tabsetPanel(
tabPanel("Schools",dataTableOutput("schoolsDT"),
tags$br(),
downloadButton("downloadschools",
"Download all rows (.csv)")),
tabPanel("Blockgroups",dataTableOutput("countsDT"),
tags$br(),
downloadButton("downloadcounts",
"Download all rows (.csv)")),
tabPanel("Trips",dataTableOutput("tripsDT"),
tags$br(),
downloadButton("downloadtrips",
"Download all rows (.csv)")),
tabPanel("Legs",dataTableOutput("legsDT"),
tags$br(),
downloadButton("downloadlegs",
"Download all rows (.csv)"))
),
tags$br(),
tags$br()
),
)
)
)),
## TAB 3 - ACS DATA EXPLORER --------------------------
tabPanel("Analytics",
sidebarLayout(
sidebarPanel(width = 3,
### SIDEBAR INPUTS ----------------------------
HTML("<font color= 'Black', size = 3><b><u>Select census data</u></b></font>"),
tags$br(),
tags$br(),
selectizeInput(inputId = "select_acs_concept",
label = "Select concept",
choices = choices_acs$concept,
selected = "SEX",
multiple = F),
uiOutput("acs"),
materialSwitch(inputId = "switch_use_percent",
label = "Use percent (of blockgroup population)", status = "info"),
actionButton(inputId = "action_generate",
label = "GENERATE",
width = "100%",
style="color: #fff; background-color: #D30000; border-color: '#D30000'"),
tags$br(),
tags$br(),
textOutput("school_warning_2")
),
### MAIN PANEL OUTPUTS ----------------------------
mainPanel(width = 9,
fluidRow(
column(5,
h3("Census Data"),
h5("Source: American Community Survey 2020"),
leafletOutput("map_census"),
tags$br()
),
column(5,
h3("School accessibility"),
h5("Schools or slots accessible by Brooklyn block group"),
leafletOutput("map3"),
tags$br()
)
),
fluidRow(
column(8, offset = 1,
h3("Scatterplot, accessibility vs. census data"),
h5("Schools or slots accessible vs selected census metric"),
plotlyOutput("scatter"),
tags$br(),
materialSwitch(inputId = "switch_flip_axes",
label = "Flip axes (for plot)", status = "primary")
)
),
fluidRow(
column(10,
h3("Joined accessibility and census data"),
h5("For census block groups in Brooklyn"),
tags$br(),
dataTableOutput("censusDT"),
tags$br(),
downloadButton("downloadcensus", "Download all rows (.csv)"),
tags$br(),
tags$br(),
tags$br()
)
)
),
)
),
## TAB 4 - DATA DICTIONARIES ---------------------
tabPanel("Data Dictionaries",
tags$div(
tags$h3("Schools Data"),
tags$h5(HTML("The <b>Schools</b> data table contains information on the schools selected by the user. The unit of observation is school, with primary key <em>school_id</em>.
These are the same schools that appear in the accessibility map layer <em> Schools </em>, which may be toggled on and off. All schools data is drawn from the
2021 Institutional Characteristics, Enrolments and Admissions tables of the Integrated Postsecondary Education Data System (IPEDS), managed by the National
Center for Education Statistics (NCES). They may be accessed <a href='https://nces.ed.gov/ipeds/datacenter/DataFiles.aspx?gotoReportId=7&'>here</a>. Variables
include the following:")),
tags$ul(
tags$li(HTML("Location information - <em>state, longitude, latitude, address, zip</em>")),
tags$li(HTML("Physical information - <em>size, multicampus</em>"),
tags$ul(tags$li(HTML("<em>multicampus</em> refers to whether or not the school has mutliple campuses")))),
tags$li(HTML("Degree-awarding information - <em>degree_level, degree_type, ipeds_category, carnegie </em>"),
tags$ul(tags$li(HTML("<em>degree_level</em> is the maximum length of degree offered, either 2-year, or 4-year and higher")),
tags$li(HTML("<em>carnegie</em> is the Carnegie classification, a commonly used tertiary education profiling framework")),
tags$li(HTML("<em>ipeds_category</em> and <em> degree_types </em>, which refer to the highest-level of degree offered")))),
tags$li(HTML("Enrolment information and racial and ethnic composition of students enrolled in 2021 for any credit"))
),
tags$h6(""),
tags$h3("Blockgroups Data"),
tags$h5(HTML("The <b>Blockgroups</b> data table contains data on the number of schools and enrolment slots accessible to each block group, given the user-defined filters
on the set of institutions under consideration, and the time cutoff and maximum transfers allowed (also inputted by the user). The unit of observation is
block group, with primary key <em>geoid</em>. The filtering criteria are also stored in the columns of this table as multi-attribute values,
so the user has a record of which criteria were used in case they wish to download the data.")),
tags$h6(""),
tags$h3("Trips Data"),
tags$h5(HTML("The <b>Trips</b> data table contains trip-level information. The unit of observation is origin-destination-run (i.e., a trip taken either in the morning or evening between two points),
uniquely identified by a composite primary key <em>odid</em> and <em>run</em>. <em>odid</em> (origin-destination id) is unique only for each origin-destination pair, so a trip taken from block group A
to school B in the morning will have the same <em>odid</em> as a trip taken from school B to block group A in the evening. <em>school_id</em> and <em>geoid</em> uniquely identify schools and
block groups respectively, as in other tables. Other trip-level variables are prefixed with <em><b>t_</b></em>:")),
tags$ul(
tags$li(HTML("<em>t_nlegs</em> refers to the total number of commuting legs in the trip, including walking, whereas <em>t_transit</em> excludes walking legs.")),
tags$li(HTML("<em>t_bus, t_ferry, t_heavyrail, t_subway, t_tram</em> refer to the total number of transit legs on that particular mode of public transit")),
tags$li(HTML("<em>t_departure, t_arrival</em> are trip arrival and departure times, in U.S. East Coast time.")),
tags$li(HTML("<em>t_time</em> is the end-to-end journey time in minutes (including walking, waiting and transit), while <em>t_waiting</em> captures how many minutes are spent waiting."))
),
tags$h6(""),
tags$h3("Leg Data"),
tags$h5(HTML("The <b>Legs</b> data table contains leg-level information (i.e., the individual components of a trip, for example walking to subway station X, catching the subway from
X to Y, and catching the bus from Y to Z). The unit of observation is a origin-destination-run-leg number, uniquely identified by a composite primary key <em>
odid, run</em> and <em>l_number</em>. Note that waiting does not count as a leg (only walking and commuting count). Leg-level variables are prefixed with <em><b>l_</b></em>:")),
tags$ul(
tags$li(HTML("<em>l_travelmins</em> is the leg duration in minutes, while <em>l_distance</em> is the distance travelled in metres.")),
tags$li(HTML("<em>l_mode</em> is either walking or transit, while <em>l_vehicle</em> is the type of transit (bus, subway, etc.) and is undefined for walking legs.")),
tags$li(HTML("<em>l_dep_stop, l_arr_stop</em> are the locations representing the start and end of each leg")),
tags$li(HTML("<em>l_agency</em> is the agency that operates the transit for that leg (MTA, NJ Transit, etc.) while <em>l_line</em> identifies the specific route taken (Q line, m11 bus, etc.)")),
tags$li(HTML("<em>l_num_stops</em> is the number of stops, for any type of <em>l_vehicle</em> with a stopping pattern."))
),
tags$h6(""),
tags$h3("Census Data"),
tags$h5(HTML("The <b>Joined census and accessibility</b> data table contains the user-selected variable from the 2020 American Community Survey (ACS) 5-year estimates, joined with the Blockgroups data on accessible schools and enrolment slots.
This data are provided for ease of download and external use. Unless otherwise specificied, the ACS data are estimates of the number of persons in a block group who belong to a specific group. For example, the <em>Public transportation</em> variable under the concept
<em>Means of Transportation to Work</em> represents the total number of persons who use public transport to go to work, for each block group. These totals may be converted to a percentage of block group population using a toggle switch in the sidebar.
Whether total numbers or percentages are more appropriate depends on the user's specific angle of investigation. Note that percentages do not make sense for some variables, such as median age or median household income.")),
tags$ul(
tags$li(HTML("Some census variables are nested subgroups of larger groups, for example, <em>Public transportation:Bus</em> is a subset of <em>Public transportation</em>, and <em>Public transportation:Bus:60 or more minutes</em> is a subgroup of <em>
Public tranportation:Bus</em>. Subgroup nesting is denoted by colons in the variable names.")),
tags$li(HTML("<u>Concept</u> is a higher-level grouping of ACS variables under similar themes. A subset of concepts and variables relevant to public transit and school accessibility is chosen for inclusion in this application."))
),
tags$h6(""),
tags$br()
)
)
)))
# -------------------------- Server ------------------------------
server <- shinyServer(function(input, output) {
## ADDITIONAL INPUT COMPONENTS -----
### output carnegie picker -----------------
output$carnegie <- renderUI({
pickerInput(inputId = "select_carnegie",
label = "Carnegie Classification",
choices = choices_carnegie %>%
filter(degree_types %in% input$select_degree_types) %>%
filter(sector %in% input$select_sector) %>%
filter(degree_level %in% input$select_degree_level) %>%
filter(size %in% input$select_size) %>%
pull(carnegie) %>%
unique(),
selected = choices_carnegie %>%
filter(degree_types %in% input$select_degree_types) %>%
filter(sector %in% input$select_sector) %>%
filter(degree_level %in% input$select_degree_level) %>%
filter(size %in% input$select_size) %>%
pull(carnegie) %>%
unique(),
options = list(`actions-box` = TRUE),
multiple = T)
})
### output acs selectize --------------------
output$acs <- renderUI({
selectizeInput(inputId = "select_acs_variable",
label = "Select variable",
choices = choices_acs %>%
filter(concept %in% input$select_acs_concept) %>%
pull(label),
selected = choices_acs %>%
filter(concept %in% input$select_acs_concept) %>%
pull(label) %>% first(),
multiple = F)
})
### output school_warnings ----------------
output$school_warning_1 <- renderText({
req(input$action_update)
ifelse(nrow(selected_schools())>0, "",
"Error, no schools match your selection criteria. Modify and try again.")
})
output$school_warning_2 <- renderText({
req(input$action_generate)
ifelse(nrow(selected_schools())>0, "",
"Error, no schools match your selection criteria. Go back to the previous tab, modify, update and try again.")
})
## REACTIVE COMPONENTS ----------
### selected_schools -----------------
### reactive to institution-level filters applied only
selected_schools <- eventReactive(eventExpr = input$action_update, ignoreNULL = F, {
isolate({
schools %>%
filter(size %in% input$select_size) %>%
filter(degree_level %in% input$select_degree_level) %>%
filter(sector %in% input$select_sector) %>%
filter(degree_types %in% input$select_degree_types) %>%
filter(carnegie %in% input$select_carnegie)
})
})
### data (list) ----------------------
### contains reactive trip and leg data
data <- eventReactive(eventExpr = input$action_update, ignoreNULL = F, {
list(
selected_trips = trips %>%
filter(t_time <= input$slider_cutoff) %>%
filter(t_transit <= (input$slider_transfers+1)) %>%
filter(school_id %in% selected_schools()$school_id) %>%
filter(if(input$select_run!="both") run==input$select_run else TRUE),
selected_legs = legs %>%
filter(t_time <= input$slider_cutoff) %>%
filter(t_transfer <= input$slider_transfers) %>%
filter(school_id %in% selected_schools()$school_id) %>%
filter(if(input$select_run!="both") run==input$select_run else TRUE)
)
})
### selected in range ----------------------
# reactive schools and counts with both sets of filters applied
selected_schools_in_range <- eventReactive(eventExpr = input$action_update, ignoreNULL = F,{
isolate({
selected_schools() %>%
filter(school_id %in% unique(data()$selected_trips$school_id))
})
})
selected_counts_in_range <- eventReactive(eventExpr = input$action_update, ignoreNULL = F, {
isolate({
filter_trips(data = filter(trips,
school_id %in% selected_schools()$school_id),
cutoff = input$slider_cutoff,
select_run = input$select_run,
transfers = input$slider_transfers) %>%
mutate(time_cutoff = input$slider_cutoff,
trip_am_pm = input$select_run,
trip_max_transfers = input$slider_transfers,
school_sizes = paste(input$select_size, collapse = "; "),
school_sectors = paste(input$select_sector, collapse = "; "),
school_degree_levels = paste(input$select_degree_level, collapse = "; "),
school_degree_types = paste(input$select_degree_types, collapse = "; "),
school_carnegie = paste(input$select_carnegie, collapse = "; "))
})
})
### acs data ----------------------------
# based on selections in tab 3 (analytics)
selected_acs_data <- eventReactive(eventExpr = input$action_generate, ignoreNULL = F,{
acs %>%
filter(concept == input$select_acs_concept) %>%
filter(label == input$select_acs_variable)
})
## OUTPUT TABLES ----------------
### schoolsDT -------------------
output$schoolsDT <- DT::renderDataTable(
DT::datatable(
{req(input$action_update)
req(nrow(selected_schools())>0)
selected_schools_in_range()},
extensions = 'Buttons',
options = list(paging = TRUE,
scrollX=TRUE,
searching = TRUE,
searchHighlight = TRUE,
ordering = TRUE,
dom = 'Blfrtip',
buttons = list(
list(extend = "csv", text = "Download displayed rows", filename = "displayed",
exportOptions = list(
modifier = list(page = "current")
)
)),
pageLength=10,
lengthMenu = c(10,50,100)),
class = 'nowrap display'))
### tripsDT -------------------
output$tripsDT <- DT::renderDataTable(
DT::datatable(
{req(input$action_update)
req(nrow(selected_schools())>0)
data()$selected_trips %>%
select(-enrolment)},
extensions = 'Buttons',
options = list(paging = TRUE,
scrollX=TRUE,
searching = TRUE,
searchHighlight = TRUE,
ordering = TRUE,
dom = 'Blfrtip',
buttons = list(
list(extend = "csv", text = "Download displayed rows", filename = "displayed",
exportOptions = list(
modifier = list(page = "current")
)
)),
pageLength=10,
lengthMenu = c(10,50,100)),
class = 'nowrap display'))
### legsDT -------------------
output$legsDT <- DT::renderDataTable(
DT::datatable(
{req(input$action_update)
req(nrow(selected_schools())>0)
data()$selected_legs %>%
select(-starts_with("t_"))},
extensions = 'Buttons',
options = list(paging = TRUE,
scrollX=TRUE,
searching = TRUE,
searchHighlight = TRUE,
ordering = TRUE,
dom = 'Blfrtip',
buttons = list(
list(extend = "csv", text = "Download displayed rows", filename = "displayed",
exportOptions = list(
modifier = list(page = "current")
)
)),
pageLength=10,
lengthMenu = c(10,50,100)),
class = 'nowrap display'))
### countsDT -------------------
output$countsDT <- DT::renderDataTable(
DT::datatable(
{req(input$action_update)
req(nrow(selected_schools())>0)
select(selected_counts_in_range(), -geometry)},
extensions = 'Buttons',
options = list(paging = TRUE,
scrollX=TRUE,
searching = TRUE,
searchHighlight = TRUE,
ordering = TRUE,
dom = 'Blfrtip',
buttons = list(
list(extend = "csv", text = "Download displayed rows", filename = "displayed",
exportOptions = list(
modifier = list(page = "current")
)
)),
pageLength=10,
lengthMenu = c(10,50,100)),
class = 'nowrap display'))
### censusDT ------------------------------
output$censusDT <- DT::renderDataTable(
DT::datatable(
{req(input$action_generate)
req(input$action_update)
req(nrow(selected_schools())>0)
left_join(select(selected_counts_in_range(),-geometry),
selected_acs_data(), by = "geoid") %>%
dplyr::relocate(c(concept, label, estimate, percent), .after = "name")},
extensions = 'Buttons',
options = list(paging = TRUE,
scrollX=TRUE,
searching = TRUE,
searchHighlight = TRUE,
ordering = TRUE,
dom = 'Blfrtip',
buttons = list(
list(extend = "csv", text = "Download displayed rows", filename = "displayed",
exportOptions = list(
modifier = list(page = "current")
)
)),
pageLength=10,
lengthMenu = c(10,50,100)),
class = 'nowrap display'))
### download buttons ------------------
output$downloadschools <- downloadHandler(
filename = "schools.csv",
content = function(file) {
write.csv(selected_schools_in_range(), file, row.names = FALSE)
})
output$downloadcounts <- downloadHandler(
filename = "blockgroups.csv",
content = function(file) {
write.csv(selected_counts_in_range(), file, row.names = FALSE)
})
output$downloadtrips <- downloadHandler(
filename = "trips.csv",
content = function(file) {
write.csv(select(data()$selected_trips,-enrolment), file, row.names = FALSE)
})
output$downloadlegs <- downloadHandler(
filename = "legs.csv",
content = function(file) {
write.csv(data()$selected_legs, file, row.names = FALSE)
})
output$downloadcensus <- downloadHandler(
filename = function() {
paste0(input$select_acs_concept,input$select_acs_variable, ".csv")
},
content = function(file) {
write.csv(data()$selected_legs, file, row.names = FALSE)
})
## OUTPUT MAPS ------------------
### map2 - tab2 ------------------------
output$map2 <- renderLeaflet({
req(input$action_update)
req(nrow(selected_schools())>0)
input$action_update
isolate({
tm <- tm_shape(st_as_sf(selected_counts_in_range()), "Block groups") +
tm_borders(lwd = 0.1) +
tm_fill(ifelse(input$switch_slots, "slots_accessible", "schools_accessible"), alpha = 0.5) +
tm_shape(subway) +
tm_lines(col = "color", group = "MTA Lines") +
tm_shape(shp = st_as_sf(selected_schools_in_range(),
coords = c("longitude", "latitude"),
crs = 4269) %>%
relocate(school_name)) + #tooltip title
tm_dots(group = "Schools", col = "midnightblue") +
tm_view(view.legend.position = c("right", "bottom"),
set.view = c(-73.953237,40.659816, 11),
set.zoom.limits = c(10,16))
tm %>%
tmap_leaflet() %>%
hideGroup(group = c("MTA Lines", "Schools")) %>%
addResetMapButton() %>%
addSearchOSM()
})
})
### map3 - tab3 ------------------------
output$map3 <- renderLeaflet({
req(input$action_update)
req(nrow(selected_schools())>0)
input$action_update
# input$action_generate -- NO...
isolate({
tm <- tm_shape(st_as_sf(selected_counts_in_range()), "Block groups") +
tm_borders(lwd = 0.1) +
tm_fill(ifelse(input$switch_slots, "slots_accessible", "schools_accessible"), alpha = 0.5) +
tm_shape(subway) +
tm_lines(col = "color", group = "MTA Lines") +
tm_shape(shp = st_as_sf(selected_schools_in_range(),
coords = c("longitude", "latitude"),
crs = 4269) %>%
relocate(school_name)) + #tooltip title
tm_dots(group = "Schools", col = "midnightblue") +
tm_view(view.legend.position = c("right", "bottom"),
set.view = c(-73.953237,40.659816, 11),
set.zoom.limits = c(10,16))
tm %>%
tmap_leaflet() %>%
hideGroup(group = c("MTA Lines", "Schools")) %>%
addResetMapButton() %>%
addSearchOSM()
})
})
### map_census --------------------
output$map_census <- renderLeaflet({
req(input$action_generate)
req(input$action_update)
req(nrow(selected_schools())>0)
input$action_generate
isolate({
tm <- tm_shape(st_as_sf(left_join(geoms, selected_acs_data(), by = "geoid")), "Block groups") +
tm_borders(lwd = 0.1) +
tm_fill(ifelse(input$switch_use_percent, "percent", "estimate"), alpha = 0.5) +
tm_shape(subway) +
tm_lines(col = "color", group = "MTA Lines") +
tm_shape(shp = st_as_sf(selected_schools_in_range(),
coords = c("longitude", "latitude"),
crs = 4269) %>%
relocate(school_name)) + #tooltip title
tm_dots(group = "Schools", col = "midnightblue") +
tm_view(view.legend.position = c("right", "bottom"),
set.view = c(-73.953237,40.659816, 11),
set.zoom.limits = c(10,16))
tm %>%
tmap_leaflet() %>%
hideGroup(group = c("MTA Lines", "Schools")) %>%
addResetMapButton() %>%
addSearchOSM()
})
})
## OUTPUT PLOTS -----------------
### most frequent routes -------------
output$leg_lines <- renderPlotly({
req(input$action_update)
req(nrow(selected_schools())>0)
fig <- data()$selected_legs %>%
filter(l_mode == 'TRANSIT') %$%
table(l_line) %>%
prop.table() %>%
as.data.frame() %>%
mutate(Percent = round(100*Freq,2),
"Transit Route" = as.character(l_line)) %>%
arrange(desc(Percent)) %>%
head(20) %>%
left_join(leg_colors, by = c("Transit Route"="l_line")) %>%
plot_ly(x = ~`Transit Route`,
y = ~Percent,
color = ~I(l_color),
alpha = 0.8,
type = 'bar') %>%
layout(xaxis = list(title = "", categoryorder = "total descending"))
fig
})
### agencies responsible -------------
output$leg_agency <- renderPlotly({
req(input$action_update)
req(nrow(selected_schools())>0)
fig <- data()$selected_legs %>%
filter(l_mode == 'TRANSIT') %$%
table(l_agency) %>%
as.data.frame() %>%
rename("Count"="Freq") %>%
mutate("Agency" = as.character(l_agency)) %>%
arrange(desc(Count)) %>%
left_join(agency_colors, by = c("Agency"="l_agency")) %>%
plot_ly(labels = ~Agency,
values = ~Count,
alpha = 0.8,
marker = list(colors = ~I(l_color)))
fig <- fig %>% add_pie(hole = 0.6) %>%
layout(xaxis = list(title = "", categoryorder = "total descending"),
legend = list(font = list(size = 10)))
fig
})
### analytics scatterplot ----------------------------
output$scatter <- renderPlotly({
req(input$action_generate)
req(input$action_update)
req(nrow(selected_schools())>0)
if(!input$switch_flip_axes){
plot_ly(left_join(select(selected_counts_in_range(),-geometry),
selected_acs_data(), by = "geoid"),
x = ~get(ifelse(isolate(input$switch_use_percent), "percent", "estimate")),
y = ~get(ifelse(isolate(input$switch_slots), "slots_accessible", "schools_accessible")),
mode = 'markers',
color = I("#D30000"),
type = "scatter") %>%
layout(xaxis = list(title = paste(isolate(input$select_acs_variable), ifelse(isolate(input$switch_use_percent),
"(Percent of blockgroup populuation)",
"(Raw estimate/number)"))),
yaxis = list(title = ifelse(isolate(input$switch_slots), "slots_accessible", "schools_accessible")))}
else{
plot_ly(left_join(select(selected_counts_in_range(),-geometry),
selected_acs_data(), by = "geoid"),
x= ~get(ifelse(isolate(input$switch_slots), "slots_accessible", "schools_accessible")),
y = ~get(ifelse(isolate(input$switch_use_percent), "percent", "estimate")),
mode = 'markers',
color = I("#D30000"),
type = "scatter") %>%
layout(xaxis = list(title = ifelse(isolate(input$switch_slots), "slots_accessible", "schools_accessible")),
yaxis = list(title = paste(isolate(input$select_acs_variable), ifelse(isolate(input$switch_use_percent),
"(Percent of blockgroup populuation)",
"(Raw estimate/number)"))))}
})
})
# --------------------- Run the application --------------------------
shinyApp(ui = ui, server = server)