-
Notifications
You must be signed in to change notification settings - Fork 0
/
app.R
203 lines (191 loc) · 11.4 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
# Load necessary libraries
library(shiny)
library(shinydashboard)
library(shinyjs)
library(shinyalert)
library(dplyr)
library(ggplot2)
library(tidyverse)
# Assuming functions.R is necessary and contains needed components
source("functions.R")
# Function to read HTML content and maintain formatting
readHtmlContent <- function(filepath) {
# Read the file
lines <- readLines(filepath, warn = FALSE)
# Collapse into a single HTML string, preserving HTML structure
htmlContent <- paste(lines, collapse = "\n")
return(htmlContent)
}
ui <- dashboardPage(
dashboardHeader(
title = "Trip Length Distributions - 2023 Household Travel Survey",
titleWidth = 600,
tags$li(class = "dropdown",
tags$a(href = "https://unifiedplan.org/household-travel-surveys/", target = "_blank",
"HTS Reference Material",
style = "float: right; font-size: 16px; padding: 15px;")
),
tags$li(class = "dropdown",
actionLink("showMethodology", "Methodology", icon = icon("book"),
style = "float: right; font-size: 16px; padding: 15px;")
)
),
dashboardSidebar(
radioButtons("dataSource", "Display:",
choices = list("Trip Length" = "dataLengths", "Trip Duration" = "dataDurations"),
selected = "dataLengths"),
selectInput("groupSampleSegment", "Sample Segment Group:",
choices = setNames(labelsSampleSegmentGroups$value, labelsSampleSegmentGroups$label)),
selectInput("groupModeTypeBroad", "Travel Mode:",
choices = setNames(labelsModeTypeBroad$value, labelsModeTypeBroad$label)),
selectInput("groupTripType", "Trip Purpose:",
choices = setNames(labelsTripType$value, labelsTripType$label)),
selectInput("groupNumVehicles", "Household Number of Vehicles:",
choices = setNames(labelsNumVehicles$value, labelsNumVehicles$label)),
selectInput("groupNumWorkers", "Household Number of Workers:",
choices = setNames(labelsNumWorkers$value, labelsNumWorkers$label)),
selectInput("typeChart", "Type of Plot:",
choices = c("Histogram" = "histogram", "Cumulative Distribution" = "cumulative", "Number of Records" = "records")),
selectInput("binSize", "Bin Size:",
choices = setNames(labelsBinSizes$value, labelsBinSizes$label)),
selectInput("maxX", "Max X-axis Value:",
choices = seq(5, 100, by = 5),
selected = 30)
),
dashboardBody(
uiOutput("loadingMessage"),
tags$head(
tags$style(HTML("
.shiny-output-error-validation { color: red; }
#container {
display: flex;
flex-wrap: wrap;
}
#dataPlot {
flex: 2 1 60%; /* flex-grow, flex-shrink, flex-basis */
}
#inputsContainer {
flex: 1 1 40%;
display: flex;
flex-direction: column;
}
#selectedInputs, #dataTable {
flex: 1;
padding-top: 20px; /* Add padding on top */
padding-bottom: 10px; /* Add padding on bottom */
}
"))
),
div(id = "container",
plotOutput("dataPlot"),
div(id = "inputsContainer",
textOutput("selectedInputs"),
tableOutput("dataTable")
)
)
)
)
server <- function(input, output, session) {
# Display the alert when the app is opened
shinyalert(
text ="The 2023 Utah Moves household travel survey was designed and conducted for use in regional and statewide travel demand modeling. The sample size and frame is suitable for that purpose.
\n Proper application of the dataset and use of this application is the responsibility of the user. In using the information or data herein, users assume the risk for relying on such data or information, and further agree to hold Utah's transportation agencies harmless for all liability of any accuracy or correctness of the information or data provided.
\n Users are encouraged to contact [email protected] with questions or to discuss proper uses and application of this data.",
closeOnClickOutside = FALSE,
closeOnEsc = FALSE,
confirmButtonText = "I acknowledge and agree",
confirmButtonCol = 'navy'
)
# Handle the methodology modal dialog
observeEvent(input$showMethodology, {
showModal(modalDialog(
title = "Methodology",
tags$p("The trip lengths described in this app are from the trip distances as reported in the Household Travel Survey's cleaned, weighted trip table delivered by RSG, the contractor for the survey project. The dataset has not been further post-processed with the exception that trips with a length longer than 100 miles have been excluded from this application/analysis."),
tags$p("Trip length distributions were calculated using the following steps:"),
tags$p(tags$b("Prepare distance bins")),
tags$p("A view was created that contains starting bin values for bin sizes of 1/2 mile, 1 mile and 5 miles from 0 to 100 using QUERY 1."),
tags$p(tags$b("Prepare grouping tables")),
tags$p("Five separate views were created to further group values from 5 key dimensions to the data: sample segment (geography and population), household number of workers, household number of vehicles, trip travel mode type, and trip type (purpose). The only grouping added to the current survey breakdown was an 'All' group that includes all possible values for each respective field. The 'All' group uses an attribute value of -1 to not overlap with existing attribute values. An example SQL for number of vehicles is shown in QUERY 2."),
tags$p(tags$b("Prepare main query")),
tags$p("The main query was created using the household table and the trip table joined on the hh_id field. The view for distance bins is included with a condition that the trip.distance_miles is greater than or equal to the binStart value and less than binStart + binSize. The five views for groupings are also added by using key values to link the tables. The trip_weight and number of records is aggregated for each combination of bin size and key dimension using their respective group fields. Resulting record counts in the numTripRecords field were used to judge rough accuracy of the query structure. See QUERY 3."),
tags$p(tags$b("Calculate histogram distribution and cumulative distribution")),
tags$p("A jupyter notebook was used to calculate a histogram (percentage) distribution and cumulative distribution for each combination of bin size and key dimension. The notebook can be found in this repo: https://github.com/WFRCAnalytics/Resources/blob/master/R-Shiny/2023-utah-household-travel-survey-trip-length-distribution/dataprep/trip-distance-distribution.ipynb"),
tags$h4("QUERY 1"),
HTML(readHtmlContent("query1.html")),
tags$h4("QUERY 2"),
HTML(readHtmlContent("query2.html")),
tags$h4("QUERY 3"),
HTML(readHtmlContent("query3.html")),
size = "l",
easyClose = TRUE,
footer = NULL
))
})
observe({
# Convert inputs to numeric to avoid non-numeric errors
numeric_binSize <- as.numeric(input$binSize)
numeric_maxX <- as.numeric(input$maxX)
# Handle plot rendering
output$dataPlot <- renderPlot({
# Placeholder data processing; actual logic should match your data structure and needs
selected_data <- get(input$dataSource) %>%
filter(groupSampleSegment == input$groupSampleSegment,
groupNumWorkers == input$groupNumWorkers,
groupNumVehicles == input$groupNumVehicles,
groupTripType == input$groupTripType,
groupModeTypeBroad == input$groupModeTypeBroad,
binSize == numeric_binSize)
lowerlimit <- -0.5 * numeric_binSize
if (input$typeChart == "histogram") {
ggplot(selected_data, aes(x = binStart + numeric_binSize / 2, y = pctTripWeight)) +
geom_bar(stat = "identity", position = "dodge", fill = "steelblue", width = numeric_binSize) +
scale_x_continuous(limits = c(lowerlimit, numeric_maxX + numeric_binSize / 2),
breaks = seq(0, numeric_maxX, by = 5)) +
labs(title = paste("Trip", ifelse(input$dataSource == "dataLengths", "Length", "Duration"), "Histogram"),
x = ifelse(input$dataSource == "dataLengths", "Distance (miles)", "Duration (minutes)"),
y = "Percentage")
} else if (input$typeChart == "records") {
ggplot(selected_data, aes(x = binStart + numeric_binSize / 2, y = numTripRecords)) +
geom_bar(stat = "identity", position = "dodge", fill = "steelblue", width = numeric_binSize) +
scale_x_continuous(limits = c(lowerlimit, numeric_maxX + numeric_binSize / 2),
breaks = seq(0, numeric_maxX, by = 5)) +
labs(title = paste("Number of Records by", ifelse(input$dataSource == "dataLengths", "Length", "Duration")),
x = ifelse(input$dataSource == "dataLengths", "Distance (miles)", "Duration (minutes)"),
y = "Records")
} else {
ggplot(selected_data, aes(x = binStart, y = cumPctTripWeight)) +
geom_line() +
scale_x_continuous(limits = c(lowerlimit, numeric_maxX),
breaks = seq(0, numeric_maxX, by = 5)) +
labs(title = paste("Trip", ifelse(input$dataSource == "dataLengths", "Length", "Duration"), "Cumulative Distribution"),
x = ifelse(input$dataSource == "dataLengths", "Distance (miles)", "Duration (minutes)"),
y = "Cumulative Percentage")
}
})
output$selectedInputs <- renderText({
paste("\n",
"Current Filter:",
paste0("\u00A0\u00A0\u00A0Sample Segment Group: ", labelsSampleSegmentGroups$label[labelsSampleSegmentGroups$value == input$groupSampleSegment]),
paste0("\u00A0\u00A0\u00A0Travel Mode: ", labelsModeTypeBroad$label[labelsModeTypeBroad$value == input$groupModeTypeBroad]),
paste0("\u00A0\u00A0\u00A0Trip Type: ", labelsTripType$label[labelsTripType$value == input$groupTripType]),
paste0("\u00A0\u00A0\u00A0Number of Vehicles: ", labelsNumVehicles$label[labelsNumVehicles$value == input$groupNumVehicles]),
paste0("\u00A0\u00A0\u00A0Number of Workers: ", labelsNumWorkers$label[labelsNumWorkers$value == input$groupNumWorkers]),
sep = "\n")
})
output$dataTable <- renderTable({
# Placeholder for your data table logic
selected_data_table <- get(input$dataSource) %>%
filter(groupSampleSegment == input$groupSampleSegment,
groupNumWorkers == input$groupNumWorkers,
groupNumVehicles == input$groupNumVehicles,
groupTripType == input$groupTripType,
groupModeTypeBroad == input$groupModeTypeBroad,
binSize == numeric_binSize) %>%
mutate(rangeLabel = paste0(sprintf("%.2f", binStart), " to ", sprintf("%.2f", binStart + binSize - 0.01))) %>% # Create a new column with the range label and format numbers
select(rangeLabel, numTripRecords, sumTripWeight, pctTripWeight, cumPctTripWeight) # Select specific columns
# Display the filtered and selected data
selected_data_table
})
})
}
shinyApp(ui = ui, server = server)