-
-
Save CaterinaC/4fdfe9bfd753dd47bdec16ca342c401b to your computer and use it in GitHub Desktop.
Exploring transport routes, journey characteristics and postcode networks using R Shiny
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# Title: Exploring transport routes, journey characteristics and postcode networks using R Shiny | |
# Author: Caterina Constantinescu | |
# Institution: The Data Lab: https://thedatalab.com/ | |
# Please credit this source if you intend to model your own code on what is shown below. | |
# Constantinescu, A.C. (2018, June). Exploring transport routes, journey characteristics and postcode networks using R Shiny [R script as GitHub Gist]. Edinburgh, Scotland: The Data Lab Innovation Centre. Retrieved [Month] [Day], [Year], from https://gist.github.com/CaterinaC/4fdfe9bfd753dd47bdec16ca342c401b | |
# TODOs ------------------------------------------------------------------- | |
# Add any TODOs here | |
# Packages ---------------------------------------------------------------- | |
library( shiny ) | |
library( shinydashboard ) | |
library( DT ) | |
library( data.table ) | |
library( plyr ) | |
library( dplyr ) | |
library( lubridate ) | |
library( prodlim ) # For row.match() | |
library( janitor ) | |
library( BBmisc ) | |
library( stringr ) | |
library( sp ) | |
library( maptools ) | |
library( leaflet ) | |
library( visNetwork ) | |
library( xlsx ) | |
library( htmlwidgets ) | |
# UI column on right hand side ---------------------------------------------------------------------- | |
ui <- | |
dashboardPage( | |
dashboardHeader( title = "Scottish Council Subsidised Transport Routes", | |
titleWidth = 625, | |
tags$li( class = "dropdown", | |
downloadButton( outputId = "downloadCriteria", | |
label = HTML( " Inputs" ), | |
class = "btn-info" ) | |
), | |
tags$li( class = "dropdown", | |
downloadButton( outputId = "downloadMap", | |
label = HTML( " Map" ), | |
class = "btn-info" ) | |
), | |
tags$li( class = "dropdown", | |
downloadButton( outputId = "downloadTables", | |
label = HTML( " Tables" ), | |
class = "btn-info" ) | |
), | |
tags$li( class = "dropdown", | |
downloadButton( outputId = "downloadNetwork", | |
label = HTML( " Network" ), | |
class = "btn-info" ) | |
) | |
), | |
dashboardSidebar( disable = TRUE ), | |
dashboardBody( | |
fluidPage( | |
tags$head( | |
tags$style( | |
HTML( "#JourneyValueBox {width: 100%;}" ) ) | |
), | |
sidebarLayout( position = "right", | |
column( width = 3, | |
box( | |
br(), | |
width = NULL, solidHeader = TRUE, | |
valueBoxOutput( "JourneyValueBox" ) | |
), | |
box( width = NULL, status = "warning", | |
radioButtons( inputId = "isUsingTimeOfDaySubsetting", inline = FALSE, | |
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Subset by time of day?</li></ul>" ), | |
choiceNames = list( "No", "Yes" ), | |
choiceValues = list( "No", "Yes" ), | |
selected = list( "No" ) ), | |
conditionalPanel( | |
condition = "input.isUsingTimeOfDaySubsetting == 'Yes'", | |
br(), | |
sliderInput( inputId = "SchTime", | |
animate = animationOptions( interval = 2500, | |
loop = FALSE, | |
playButton = icon( "play-circle", "fa-1.5x" ) ), | |
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Time of day:</li></ul>" ), | |
min = as.POSIXct( "1833-01-01 00:00:01", "%H:%M:%S" ), | |
max = as.POSIXct( "1833-01-01 23:59:59", "%H:%M:%S" ), | |
value = c( as.POSIXct( "1833-01-01 00:00:01", "%H:%M:%S" ), | |
as.POSIXct( "1833-01-01 23:59:59", "%H:%M:%S" ) ), | |
timezone = "GMT", | |
timeFormat = "%H:%M", ticks = T ), | |
br() | |
) | |
), | |
box( width = NULL, status = "warning", | |
checkboxGroupInput( inputId = "Quarter", inline = FALSE, | |
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Journey quarter:</li></ul>" ), | |
choiceNames = list( "2015 Q4", | |
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4", | |
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ), | |
choiceValues = list( "2015.4", | |
"2016.1", "2016.2", "2016.3", "2016.4", | |
"2017.1", "2017.2", "2017.3", "2017.4" ), | |
selected = list( "2015.4", | |
"2016.1", "2016.2", "2016.3", "2016.4", | |
"2017.1", "2017.2", "2017.3", "2017.4" ) | |
), | |
HTML( "<ul style='padding-left: 1.25em;'}><li><strong>Batch select quarters:</strong></li></ul>" ), | |
div( style = "position:relative;left:0%;padding:0px", | |
actionButton( inputId = 'tick2015', '2015' ), | |
actionButton( inputId = 'tick2016', '2016' ), | |
actionButton( inputId = 'tick2017', '2017' ), | |
actionButton( inputId = 'tick2015_2017', 'Full period' ) | |
) | |
), | |
box( width = NULL, status = "warning", | |
checkboxGroupInput( inputId = "DayOfTheWeek", inline = FALSE, | |
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Day of the week:</li></ul>" ), | |
choiceNames = list( "Monday", "Tuesday", "Wednesday", | |
"Thursday", "Friday", "Saturday", "Sunday" ), | |
choiceValues = list( "Monday", "Tuesday", "Wednesday", | |
"Thursday", "Friday", "Saturday", "Sunday" ), | |
selected = list( "Monday", "Tuesday", "Wednesday", | |
"Thursday", "Friday", "Saturday", "Sunday" ) ), | |
HTML( "<ul style='padding-left: 1.25em;'}><li><strong>Batch select days of the week:</strong></li></ul>" ), | |
div( style = "position:relative;left:0%;padding:0px", | |
actionButton( inputId = 'tickWeekday', 'Weekdays' ), | |
actionButton( inputId = 'tickWeekend', 'Weekend' ), | |
actionButton( inputId = 'tickFullWeek', 'Full week' ) ) | |
), | |
box( | |
width = NULL, status = "warning", | |
radioButtons( inputId = "isUsingPostCodePopups", inline = FALSE, | |
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Show postcodes on map?</li></ul>" ), | |
choiceNames = list( "No", "Yes" ), | |
choiceValues = list( "No", "Yes" ), | |
selected = list( "No" ) | |
) | |
) | |
), | |
# Output tabs in UI ------------------------------------------------------------------ | |
column( width = 9, | |
tabBox( | |
title = tags$a( tags$img( src = 'TheDataLab-Black-Logo-transparent-small.png', height = '33', width = '100' ), | |
href = 'https://www.thedatalab.com/' ), | |
id = "outputTabs", | |
width = NULL, | |
side = "left", | |
# 1. | |
tabPanel( tagList( icon = icon( "map-signs", "fa-1x" ), HTML(" "), "Journey maps" ), | |
leafletOutput( outputId = "leafletMap", width = "100%", height = 800 ) | |
), | |
# 2. | |
tabPanel( tagList( icon = icon( "table" ), HTML(" "), "Data summaries" ), | |
fluidRow( | |
column( width = 4, dataTableOutput( outputId = "summaryPurposeTable" ) ), | |
column( width = 5, dataTableOutput( outputId = "summaryOperatorTable" ) ), | |
column( width = 3, dataTableOutput( outputId = "summaryDayOfTheWeekTable" ) | |
) | |
), | |
br(), | |
fluidRow( | |
column( width = 4, dataTableOutput( outputId = "summaryOccupantsTable" ) ), | |
column( width = 5, dataTableOutput( outputId = "summaryTimeOfDayTable" ) ), | |
column( width = 3, dataTableOutput( outputId = "summaryQuarterTable" ) | |
) | |
) | |
), | |
# 3. | |
tabPanel( tagList( icon = icon( "connectdevelop" ), HTML(" "), "Postcode network" ), | |
visNetworkOutput( outputId = "postcodeNetwork", width = "100%", height = 800 ) | |
) | |
), | |
# UI row of menus below -------------------------------------------------------------- | |
fluidRow( | |
column( width = 4, | |
box( width = NULL, status = "warning", height = "300px", | |
selectInput( inputId = "Purpose", | |
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Journey purpose:</li></ul>" ), | |
list( `Any purpose` = "Any", | |
`Recreational activities` = c( "Shopping", "Social", "Retreat", "Sports", "Tourist" ), | |
`Professional & educational activities` = c( "Employment", "School" ), | |
`Commitments / appointments` = c( "Meeting", "Doctor" ), | |
`Transport connection` = c( "Bus connection", "Train connection" ), | |
`Misc` = c( "Church", "Personal", "Other" ) ) ) | |
) | |
), | |
column( width = 4, | |
box( width = NULL, status = "warning", height = "300px", | |
selectInput( inputId = "Operator", | |
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Journey operator:</li></ul>" ), | |
list( `Any operator` = c( "Any"), | |
`Cab/Coach companies` = c( "A", | |
"B", | |
"C", | |
"D", | |
"E", | |
"F", | |
"G", | |
"H" ), | |
`Transport schemes` = c( "Area 1 scheme", | |
"Area 2 scheme", | |
"Area 3 scheme (Mon, Wed, Fri)", | |
"Area 3 scheme (Tue, Thu, Sat)" ) ) ) | |
) | |
), | |
column( width = 4, | |
box( width = NULL, status = "warning", height = "300px", | |
selectInput( inputId = "Occupants", | |
label = HTML( "<ul style='padding-left: 1.25em;'}><li>Number of occupants:</li></ul>" ), | |
list( `Any number of occupants` = c( "Any"), | |
`1` = 1, | |
`2` = 2, | |
`3` = 3, | |
`4` = 4, | |
`5` = 5, | |
`6` = 6, | |
`7` = 7, | |
`8` = 8 ) | |
) | |
) | |
) | |
) | |
) | |
) | |
) | |
) | |
) | |
# SERVER ------------------------------------------------------------------ | |
server <- function( input, output, session ) { | |
# Custom functions - run ONCE -------------------------------------------------------- | |
getTabularSummary <- function( criterion, recodeQuarters = FALSE, timeOfDay = FALSE ) { | |
# For table of times of day | |
if ( timeOfDay == FALSE ) { | |
smry <- data.frame( tabyl( getDataSubset()[ , get( criterion ) ] ) ) | |
} | |
else { | |
smry <- data.frame( | |
tabyl( | |
format( | |
as.POSIXct( | |
cut( getDataSubset()$JourneyStart, | |
breaks = "h") ), | |
"%H:%M:%S" ) ) ) | |
} | |
# For yearly quarters | |
if ( recodeQuarters == TRUE ) { | |
smry[[1]] <- mapvalues( smry[[1]], | |
c( "2015.4", | |
"2016.1", "2016.2", "2016.3", "2016.4", | |
"2017.1", "2017.2", "2017.3", "2017.4" ), | |
c( "2015 Q4", | |
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4", | |
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ) ) | |
} | |
# For everything, regardless of type: | |
if ( ncol( smry ) == 4 ) { | |
# 4 columns = missing values are present, hence another 'Valid percent' column is generated besides the regular 'percent' one. | |
names( smry ) <- c( criterion, "Journeys", "%", "Valid %" ) | |
smryMissings <- smry[ nrow( smry ), ] | |
smryMissings[[1]] <- "NA" | |
smryMissings[[3]] <- round( smryMissings[[3]], digits = 3 ) | |
smry <- smry[ - nrow( smry ), ] | |
smry <- smry[ order( smry$Journeys, decreasing = TRUE ), ] | |
smry$`%` <- round( smry$`%`, digits = 3 ) | |
smry$`Valid %` <- round( smry$`Valid %`, digits = 3 ) | |
rbind( smry, smryMissings ) | |
} | |
else { | |
# If no missing data is present, there will be 3 columns. | |
names( smry ) <- c( criterion, "Journeys", "%" ) | |
smry$`%` <- round( smry$`%`, digits = 3 ) | |
return( smry[ order( smry$Journeys, decreasing = TRUE ), ] ) | |
} | |
} | |
# Get data and transform some cols - also run ONCE ----------------------------------- | |
# Run once: | |
tryCatch( load( "my/path/RequiredByShinyApp.RData", | |
envir = globalenv() ), | |
error = function(e) { | |
load( "my/other/path/RequiredByShinyApp.RData", | |
envir = globalenv() ) | |
} ) | |
# Transform some data once: | |
data_geocode_from_to_journeys_found[ , JourneyStart := ymd_hms( as.POSIXct( ifelse( RequestType == "PickUp", | |
Est, | |
Est - ( VehicleTimeMinutes * 60 ) ), | |
origin = '1970-01-01', tz = "UTC" ) ) ] | |
data_geocode_from_to_journeys_found[ , JourneyDecimalStartHour := hour( JourneyStart ) + minute( JourneyStart ) / 60 ] | |
# Update QUARTER checkbox inputs based on actionButtons --------------------------- | |
observe({ | |
if ( input$tick2015 > 0 ) { | |
updateCheckboxGroupInput( session = session, | |
inputId = "Quarter", | |
choiceNames = list( "2015 Q4", | |
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4", | |
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ), | |
choiceValues = list( "2015.4", | |
"2016.1", "2016.2", "2016.3", "2016.4", | |
"2017.1", "2017.2", "2017.3", "2017.4" ), | |
selected = list( "2015.4" ) ) | |
} | |
}) | |
observe({ | |
if ( input$tick2016 > 0 ) { | |
updateCheckboxGroupInput( session = session, | |
inputId = "Quarter", | |
choiceNames = list( "2015 Q4", | |
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4", | |
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ), | |
choiceValues = list( "2015.4", | |
"2016.1", "2016.2", "2016.3", "2016.4", | |
"2017.1", "2017.2", "2017.3", "2017.4" ), | |
selected = list( "2016.1", "2016.2", "2016.3", "2016.4" ) ) | |
} | |
}) | |
observe({ | |
if ( input$tick2017 > 0 ) { | |
updateCheckboxGroupInput( session = session, | |
inputId = "Quarter", | |
choiceNames = list( "2015 Q4", | |
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4", | |
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ), | |
choiceValues = list( "2015.4", | |
"2016.1", "2016.2", "2016.3", "2016.4", | |
"2017.1", "2017.2", "2017.3", "2017.4" ), | |
selected = list( "2017.1", "2017.2", "2017.3", "2017.4" ) ) | |
} | |
}) | |
observe({ | |
if ( input$tick2015_2017 > 0 ) { | |
updateCheckboxGroupInput( session = session, | |
inputId = "Quarter", | |
choiceNames = list( "2015 Q4", | |
"2016 Q1", "2016 Q2", "2016 Q3", "2016 Q4", | |
"2017 Q1", "2017 Q2", "2017 Q3", "2017 Q4" ), | |
choiceValues = list( "2015.4", | |
"2016.1", "2016.2", "2016.3", "2016.4", | |
"2017.1", "2017.2", "2017.3", "2017.4" ), | |
selected = list( "2015.4", | |
"2016.1", "2016.2", "2016.3", "2016.4", | |
"2017.1", "2017.2", "2017.3", "2017.4" ) ) | |
} | |
}) | |
# Update DAY OF THE WEEK checkbox input ----------------------------------- | |
observe({ | |
if ( input$tickWeekday > 0 ) { | |
updateCheckboxGroupInput( session = session, | |
inputId = "DayOfTheWeek", | |
choiceNames = list( "Monday", "Tuesday", "Wednesday", | |
"Thursday", "Friday", "Saturday", "Sunday" ), | |
choiceValues = list( "Monday", "Tuesday", "Wednesday", | |
"Thursday", "Friday", "Saturday", "Sunday" ), | |
selected = list( "Monday", "Tuesday", "Wednesday", "Thursday", "Friday" ) ) | |
} | |
}) | |
observe({ | |
if ( input$tickWeekend > 0 ) { | |
updateCheckboxGroupInput( session = session, | |
inputId = "DayOfTheWeek", | |
choiceNames = list( "Monday", "Tuesday", "Wednesday", | |
"Thursday", "Friday", "Saturday", "Sunday" ), | |
choiceValues = list( "Monday", "Tuesday", "Wednesday", | |
"Thursday", "Friday", "Saturday", "Sunday" ), | |
selected = list( "Saturday", "Sunday" ) ) | |
} | |
}) | |
observe({ | |
if ( input$tickFullWeek > 0 ) { | |
updateCheckboxGroupInput( session = session, | |
inputId = "DayOfTheWeek", | |
choiceNames = list( "Monday", "Tuesday", "Wednesday", | |
"Thursday", "Friday", "Saturday", "Sunday" ), | |
choiceValues = list( "Monday", "Tuesday", "Wednesday", | |
"Thursday", "Friday", "Saturday", "Sunday" ), | |
selected = list( "Monday", "Tuesday", "Wednesday", | |
"Thursday", "Friday", "Saturday", "Sunday" ) ) | |
} | |
}) | |
# DATA PREP: Run each time inputs change ---------------------------------- | |
# 1. Tidy up some input values ------------------------------------------------------- | |
getDataSubset <- reactive({ | |
redefinedPurpose <- mapvalues( input$Purpose, | |
c( "Bus connection", "Train connection" ), | |
c( "BusConnection", "TrainConnection" ) ) | |
redefinedOperator <- mapvalues( input$Operator, | |
c( "Area 3 (Mon, Wed, Fri)", "Area 3 (Tue, Thu, Sat)" ), | |
c( "Area.3 (Monday, Wednesday, Friday)", "Area.3 (Tuesday, Thursday, Saturday)" ) ) | |
# 2. Subset by DAY OF THE WEEK, QUARTER, and TIME OF DAY ----------------------------------------------- | |
selected_interval <- data_geocode_from_to_journeys_found[ DayOfTheWeek %in% c( input$DayOfTheWeek ) & | |
Quarter %in% c( input$Quarter ), ] | |
# Optional step with excludes cases with missing time-of-day info: | |
if ( input$isUsingTimeOfDaySubsetting == "Yes" ) { | |
# Now compare this to input: | |
inputStartHour <- hour( input$SchTime[1] ) + minute( input$SchTime[1] ) / 60 | |
inputEndHour <- hour( input$SchTime[2] ) + minute( input$SchTime[2] ) / 60 | |
selected_interval <- selected_interval[ inputStartHour < JourneyDecimalStartHour & JourneyDecimalStartHour <= inputEndHour, ] | |
} | |
# 3. Subset routes by PURPOSE, OPERATOR and OCCUPANTS ------------------------------- | |
# 1. ALL PARAMS FREE: | |
if ( redefinedPurpose == "Any" & redefinedOperator == "Any" & input$Occupants == "Any" ) { | |
# Simply not subsetting and carrying on: | |
selected_subset <- selected_interval | |
} # ALL PARAMS FIXED: | |
else if ( redefinedPurpose != "Any" & redefinedOperator != "Any" & input$Occupants != "Any" ) { | |
selected_subset <- selected_interval[ Purpose == redefinedPurpose & Operator == redefinedOperator & Occupants == input$Occupants, ] | |
} # ONLY PURPOSE FIXED: | |
else if ( redefinedPurpose != "Any" & redefinedOperator == "Any" & input$Occupants == "Any" ) { | |
selected_subset <- selected_interval[ Purpose == redefinedPurpose, ] | |
} # ONLY OPERATOR FIXED: | |
else if ( redefinedPurpose == "Any" & redefinedOperator != "Any" & input$Occupants == "Any" ) { | |
selected_subset <- selected_interval[ Operator == redefinedOperator, ] | |
} # ONLY OCCUPANTS FIXED: | |
else if ( redefinedPurpose == "Any" & redefinedOperator == "Any" & input$Occupants != "Any" ) { | |
selected_subset <- selected_interval[ Occupants == input$Occupants, ] | |
} # ONLY PURPOSE FREE, BUT OPERATOR AND OCCUPANTS FIXED: | |
else if ( redefinedPurpose == "Any" & redefinedOperator != "Any" & input$Occupants != "Any" ) { | |
selected_subset <- selected_interval[ Operator == redefinedOperator & Occupants == input$Occupants, ] | |
} # ONLY OCCUPANTS FREE, BUT OPERATOR AND PURPOSE FIXED: | |
else if ( redefinedPurpose != "Any" & redefinedOperator != "Any" & input$Occupants == "Any" ) { | |
selected_subset <- selected_interval[ Purpose == redefinedPurpose & Operator == redefinedOperator, ] | |
} # ONLY OPERATOR FREE, BUT PURPOSE AND OCCUPANTS FIXED: | |
else if ( redefinedPurpose != "Any" & redefinedOperator == "Any" & input$Occupants != "Any" ) { | |
selected_subset <- selected_interval[ Purpose == redefinedPurpose & Occupants == input$Occupants, ] | |
} | |
else { # THIS LOGIC DOES NOT INCLUDE AN OPTION FOR WHEN E.G., PURPOSE IS MISSING. | |
stop( "Unknown combination of trip attributes. Try changing the purpose, operator, or number of occupants." ) | |
} | |
return( selected_subset ) | |
}) | |
# Recompute volumes post-subset ------------------------------------------- | |
getSubsetVolumes <- reactive({ | |
# Recompute volumes right after subset, otherwise the numbers will be shared with a bunch of other params: | |
subset_volumes <- na.exclude( ddply( getDataSubset(), .( FromLatitude, FromLongitude, ToLatitude, ToLongitude ), nrow ) ) | |
if ( nrow( subset_volumes ) > 0 ) { | |
setnames( setDT( subset_volumes ), "V1", "Volume" ) | |
} | |
return( subset_volumes ) | |
}) | |
getSpatialLinesObj <- reactive({ | |
# Find the index of these social purpose routes within the listing of all unique journeys: | |
index_selected_routes <- prodlim::row.match( getSubsetVolumes()[ , -5 ], journeys_found, nomatch = NA ) | |
# journeys_found is taken from memory i.e., the .RData loaded at the start. | |
# Now pull put the spatial lines associated with these particular trips: | |
lst_lines_social <- lst_lines[ index_selected_routes ] | |
# Wrap it up and put a bow on it: | |
spl_lst <- SpatialLines( lst_lines_social ) | |
return( spl_lst ) | |
}) | |
getColorVector <- reactive({ | |
if ( nrow( getSubsetVolumes() ) > 0 ) { | |
cold_hot_palette <- colorRampPalette( c( "black", "brown1" ) ) | |
color_index <- data.frame( colorName = cold_hot_palette( length( unique( getSubsetVolumes()$Volume ) ) ), | |
Volume = sort( unique( getSubsetVolumes()$Volume ) ) ) | |
color_vector <- join( getSubsetVolumes(), color_index, by = "Volume" )$colorName | |
return( color_vector ) | |
} | |
else { | |
stop( "No journeys exist for this combination of criteria. Try again!" ) | |
} | |
}) | |
# Get relevant postcode names to use as popups ---------------------------- | |
getRelevantPopups <- reactive({ | |
if( nrow( getDataSubset() ) > 0 ) { | |
FromPostcodePopups <- getDataSubset()[ , .SD, .SDcols = c( "FromZipCode", "FromLongitude", "FromLatitude" ) ] | |
setnames( FromPostcodePopups, c( "ZipCode", "Longitude", "Latitude" ) ) | |
ToPostcodePopups <- getDataSubset()[ , .SD, .SDcols = c( "ToZipCode", "ToLongitude", "ToLatitude") ] | |
setnames( ToPostcodePopups, c( "ZipCode", "Longitude", "Latitude" ) ) | |
PostCodePopups <- rbind( FromPostcodePopups, ToPostcodePopups ) | |
PostCodePopups <- PostCodePopups[ ! duplicated( PostCodePopups ), ] | |
return( PostCodePopups ) | |
} | |
}) | |
# A. Render leaflet map -------------------------------------------------------- | |
drawLeafletMapItself <- reactive({ | |
cityMap <- leaflet( ) %>% | |
# or CartoDB.DarkMatter | |
addProviderTiles( "HikeBike.HikeBike" ) %>% | |
addCircleMarkers( lng = ~ToLongitude, | |
lat = ~ToLatitude, | |
data = data.frame( getSubsetVolumes() ), | |
stroke = FALSE, | |
fillOpacity = 0.50, radius = 5, | |
color = "#ff5d00" ) %>% | |
addCircleMarkers( lng = ~FromLongitude, | |
lat = ~FromLatitude, | |
data = data.frame( getSubsetVolumes() ), | |
stroke = FALSE, fillOpacity = 0.50, radius = 5, | |
color = "#ff5d00" ) %>% | |
addPolylines( data = getSpatialLinesObj(), | |
weight = sqrt( getSubsetVolumes()$Volume ), | |
# Normalised the data here between a min and max: | |
opacity = normalize( sqrt( getSubsetVolumes()$Volume ), method = "range", range = c( 0.05, 0.60 ) ), | |
color = getColorVector(), | |
# color = "tomato", | |
label = paste( | |
"# Journeys = ", | |
as.character( getSubsetVolumes()$Volume ) ), | |
stroke = TRUE ) %>% | |
addMarkers( lng = as.numeric( city_centre_position[ 1 ] ), | |
lat = as.numeric( city_centre_position[ 2 ] ), # These is just a vector of coords defining the centre of the city | |
popup = "city centre" ) %>% | |
# This will fix the zoom level and centre for the map, so that it is more obvious how the flow of journeys changes over time. | |
setView( lng = -3.5, | |
lat = 53, | |
zoom = 10 ) | |
if ( input$isUsingPostCodePopups == "No" ) { | |
cityMap | |
} | |
else { | |
cityMap %>% | |
addMarkers( data = getRelevantPopups(), | |
lng = ~Longitude, | |
lat = ~Latitude, | |
label = ~ZipCode, | |
labelOptions = labelOptions( noHide = F, textsize = "8px", maxHeight = 20 ) ) | |
} | |
}) | |
output$leafletMap <- renderLeaflet({ | |
drawLeafletMapItself() | |
}) | |
# B. Render value box -------------------------------------------------------- | |
output$JourneyValueBox <- renderValueBox({ | |
if ( nrow( getDataSubset() ) > 0 ) { | |
valueBox( | |
nrow( getDataSubset() ), "Journeys", icon = icon( "taxi", lib = "font-awesome" ), | |
color = "green" | |
) | |
} | |
else { | |
valueBox( | |
0, "Journeys", icon = icon( "taxi", lib = "font-awesome" ), | |
color = "red" | |
) | |
} | |
}) | |
# C. Render tables in Data summary tab --------------------------------------- | |
output$summaryPurposeTable <- renderDataTable({ | |
if ( nrow( getDataSubset() ) > 0 ) { | |
datatable( getTabularSummary( "Purpose" ), | |
rownames = FALSE, | |
options = list( dom = 't', | |
paging = FALSE, | |
scrollY = "330px" ) ) | |
} else { | |
stop( "No journeys exist for this combination of criteria. Try again!" ) | |
} | |
}) | |
output$summaryOperatorTable <- renderDataTable({ | |
if ( nrow( getDataSubset() ) > 0 ) { | |
datatable( getTabularSummary( "Operator" ), | |
rownames = FALSE, | |
options = list( dom = 't', | |
paging = FALSE, | |
scrollY = "330px" ) ) | |
} | |
}) | |
output$summaryOccupantsTable <- renderDataTable({ | |
if ( nrow( getDataSubset() ) > 0 ) { | |
datatable( getTabularSummary( "Occupants" ), | |
rownames = FALSE, | |
options = list( dom = 't' ) ) | |
} | |
}) | |
output$summaryTimeOfDayTable <- renderDataTable({ | |
if ( nrow( getDataSubset() ) > 0 ) { | |
datatable( getTabularSummary( "JourneyStart", recodeQuarters = FALSE, timeOfDay = TRUE ), | |
rownames = FALSE, | |
options = list( dom = 't', | |
paging = FALSE, | |
scrollY = "333px" ) ) | |
} | |
}) | |
output$summaryQuarterTable <- renderDataTable({ | |
if ( nrow( getDataSubset() ) > 0 ) { | |
datatable( getTabularSummary( "Quarter", recodeQuarters = TRUE ), | |
rownames = FALSE, | |
options = list( dom = 't' ) ) | |
} | |
}) | |
output$summaryDayOfTheWeekTable <- renderDataTable({ | |
if ( nrow( getDataSubset() ) > 0 ) { | |
datatable( getTabularSummary( "DayOfTheWeek" ), | |
rownames = FALSE, | |
options = list( dom = 't' ) ) | |
} | |
}) | |
# D. Render postcode network -------------------------------------------------------- | |
drawNetworkItself <- reactive({ | |
edges_or_links <- ddply( getDataSubset(), .( FromZipCode, ToZipCode ), nrow ) | |
names( edges_or_links ) <- c( "from", "to", "value" ) # width = weight | |
link_data <- edges_or_links | |
setDT( link_data ) | |
link_data[ , arrows := "to" ] | |
nodes <- unique( c( edges_or_links$from, edges_or_links$to ) ) | |
node_data <- data.frame( id = nodes, | |
label = nodes, | |
color.background = "tomato" ) | |
setDT( node_data ) | |
visNetwork( nodes = node_data, | |
edges = link_data, | |
width = "100%", | |
height = "800px" ) %>% | |
visOptions( highlightNearest = TRUE ) %>% | |
visPhysics( solver = "forceAtlas2Based" ) %>% | |
visLayout( randomSeed = 123 ) | |
}) | |
output$postcodeNetwork <- renderVisNetwork({ | |
if ( nrow( getDataSubset() ) > 0 ) { | |
drawNetworkItself() | |
} | |
else { | |
stop( "No journeys exist for this combination of criteria. Try again!" ) | |
} | |
}) | |
# EXPORT -------------------------------------------------------------------------------------- | |
output$downloadCriteria <- downloadHandler( | |
filename = function() { | |
paste( 'DRT-Shiny-InputCriteria', | |
format( input$SchTime[1], "%H:%M:%S" ), | |
format( input$SchTime[2], "%H:%M:%S" ), | |
str_replace_all( paste( input$Quarter, collapse = "-" ), "[.]", "Q" ), | |
paste( input$DayOfTheWeek, collapse = "-" ), | |
input$Purpose, | |
input$Operator, | |
'.txt', sep = '__' ) | |
}, | |
content = function( file ) { | |
inputCriteria <- data.frame( `SubsettingByTimeOfDay...` = input$isUsingTimeOfDaySubsetting, | |
`StartTime...` = format( input$SchTime[1], "%H:%M:%S" ), | |
`EndTime...` = format( input$SchTime[2], "%H:%M:%S" ), | |
`Quarters...` = paste( input$Quarter, collapse = " - " ), | |
`DaysOfTheWeek...` = paste( input$DayOfTheWeek, collapse = " - " ), | |
`ShowingPostcodePopupsOnMap...` = input$isUsingPostCodePopups, | |
`Purpose...` = input$Purpose, | |
`Operator...` = input$Operator, | |
`Occupants...` = input$Occupants, | |
`Journeys...` = nrow( getDataSubset() ) ) | |
write.table( t( inputCriteria ), | |
file, | |
col.names = FALSE, | |
quote = FALSE ) | |
} | |
) | |
output$downloadMap <- downloadHandler( | |
filename = function() { | |
paste( 'DRT-Shiny-Map', | |
format( input$SchTime[1], "%H:%M:%S" ), | |
format( input$SchTime[2], "%H:%M:%S" ), | |
str_replace_all( paste( input$Quarter, collapse = "-" ), "[.]", "Q" ), | |
paste( input$DayOfTheWeek, collapse = "-" ), | |
input$Purpose, | |
input$Operator, | |
'.html', sep = '__' ) | |
}, | |
content = function( file ) { | |
saveWidget( drawLeafletMapItself(), file ) | |
} | |
) | |
output$downloadNetwork <- downloadHandler( | |
filename = function() { | |
paste( 'DRT-Shiny-Network', | |
format( input$SchTime[1], "%H:%M:%S" ), | |
format( input$SchTime[2], "%H:%M:%S" ), | |
str_replace_all( paste( input$Quarter, collapse = "-" ), "[.]", "Q" ), | |
paste( input$DayOfTheWeek, collapse = "-" ), | |
input$Purpose, | |
input$Operator, | |
'.html', sep = '__' ) | |
}, | |
content = function( file ) { | |
saveWidget( drawNetworkItself(), file ) | |
} | |
) | |
output$downloadTables <- downloadHandler( | |
filename = function() { | |
paste( 'DRT-Shiny-Tables', | |
format( input$SchTime[1], "%H:%M:%S" ), | |
format( input$SchTime[2], "%H:%M:%S" ), | |
str_replace_all( paste( input$Quarter, collapse = "-" ), "[.]", "Q" ), | |
paste( input$DayOfTheWeek, collapse = "-" ), | |
input$Purpose, | |
input$Operator, | |
'.xlsx', sep = '__' ) | |
}, | |
content = function( file ) { | |
write.xlsx( getTabularSummary( "Purpose" ), | |
file = file, sheetName = "Purpose", | |
row.names = FALSE ) | |
write.xlsx( getTabularSummary( "Operator" ), | |
file = file, sheetName = "Operator", | |
append = TRUE, | |
row.names = FALSE ) | |
write.xlsx( getTabularSummary( "Occupants" ), | |
file = file, sheetName = "Occupants", | |
append = TRUE, | |
row.names = FALSE ) | |
write.xlsx( getTabularSummary( "JourneyStart", recodeQuarters = FALSE, timeOfDay = TRUE ), | |
file = file, sheetName = "JourneyStart", | |
append = TRUE, | |
row.names = FALSE ) | |
write.xlsx( getTabularSummary( "Quarter", recodeQuarters = TRUE ), | |
file = file, sheetName = "Quarter", | |
append = TRUE, | |
row.names = FALSE ) | |
write.xlsx( getTabularSummary( "DayOfTheWeek" ), | |
file = file, sheetName = "DayOfTheWeek", | |
append = TRUE, | |
row.names = FALSE ) | |
} | |
) | |
} | |
# You should not have any R code after the line below; it needs to be the last line in your file. | |
shinyApp( ui = ui, server = server ) | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment