/exampleTransportShinyApp.R
Secret
Last active Sep 20, 2019
Exploring transport routes, journey characteristics and postcode networks using R Shiny
| # 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