Skip to content
Permalink
f71e7a6907
Switch branches/tags

Name already in use

A tag already exists with the provided branch name. Many Git commands accept both tag and branch names, so creating this branch may cause unexpected behavior. Are you sure you want to create this branch?

IDEA-COVID-StudySafe/app.R.bak

Go to file
 
 
Cannot retrieve contributors at this time
1125 lines (922 sloc) 66.2 KB
Raw Blame
# Data Incite RPI Study Safe App using UI Template
# Uses Shinydashboard as a framework https://rstudio.github.io/shinydashboard/
# UI Template Created by Arielle Cerini, Brian Hotopp, Haoyu He, and James Young
# Edited by Kara Kniss
# Version: 26 Jan 2021
#document for reading in the relevant libraries, data, and cleaning
source('read_wapData.R')
#LINK TO FEEDBACK SURVEY
survey_url <- tags$a("survey", href = "https://docs.google.com/forms/d/e/1FAIpQLScvNquZHFMPXmzvj2_FGpzjpC7eMmfMEeO4sM_aSqZNhYCBFg/viewform?usp=sf_link", style = 'color: #990000; background-color: #FAFAFA')
#LINK TO USABILITY STUDY
usability_study_url <- tags$a("usability study", href = "https://forms.gle/tpMfaMv5dBfXSJUH6", style = 'color: #990000; background-color: #FAFAFA')
ui <- dashboardPage(skin = "black", title = "RPI StudySafe",
#HEADER
dashboardHeader(title = tags$div(
class = "title-text",
tags$style(".logo {max-width: 80%;}"),
tags$div(id = "logo_block", tags$img(class="logo", src="Rensselaer.png", id="Rensselear Polytechnic Institute Logo") )),
titleWidth = "340px"
)
,
#TOGGLED SIDEBAR
dashboardSidebar(
width = 320,
sidebarMenu(id = "tabs", collapsed = TRUE,
menuItem("Campus Map", tabName = "map", selected = TRUE),
menuItem("Find a Place To Study", tabName = "find"),
menuItem('Quick Compare', tabName='overview'),
menuItem("About", tabName = "about"),
tags$div(HTML("<br></br>")),
box(width= 12, collapsible = TRUE, title = tags$div(HTML("<span style = 'color: #54585a '>Feedback Forms</span>")),
style = 'color: #54585a;', solidHeader=TRUE,
tagList("Have any comments? Please follow the link to",
tags$br(),
"this", survey_url, "and let us know if you have any",
tags$br(),
" issues, questions, or suggestions regarding",
tags$br(),
" the StudySafe app."),
tags$br(), tags$br(),
tagList("Help us make the app better! Take a few",
tags$br(),
"minutes to participate in our ",usability_study_url, ".")
),
uiOutput("side_ctrl")
)
),
#BODY WITH REACTIVE TABS
dashboardBody(
style = "background-color: #f7f7f7; height: 100%; min-height: 100vh;",
shinyjs::useShinyjs(),
tabItems(
#ABOUT TAB
tabItem(tabName = "about",
uiOutput("about_body"),
tags$div(HTML("<br></br>")),
tags$div(
HTML("<h1 style = 'text-align: left'>About <span style = 'color:#54585a'>RPI</span> <b><span style = 'color: #990000;'>StudySafe</span></b></h1>
<div style='margin-left: 5%'>
<p>RPI StudySafe is an app that reveals the anonymous usage of Wi-Fi access points and aggregations of wireless users on
the campus network at <a href = 'https://rpi.edu'; style = 'color: #990000; background-color: #f7f7f7'>Rensselaer Polytechnic Institute</a>,
Troy, New York. Analysis and visualizations are by students and staff of
<a href = 'https://idea.rpi.edu'; style = 'color: #990000; background-color: #f7f7f7'>The Rensselaer Institute for Data Exploration and Applications (IDEA)</a>.
This is an app associated with the COVID-19 contact tracing and campus network mapping projects.</p>
<p>RPI StudySafe is designed to present WAP data to on-campus users so they can make informed decisions on where to go for extended periods of time on campus.
The data can be interacted with in several ways, including selecting certain dates, times, locations, as well as through interactive geographical maps.
Geographic location and density of each WAP are combined by building, and the data is updated every two hours.</p>
</div>
<hr>
<h4 style = 'text-align: left'>Map </h4>
<div style='margin-left: 1%'>
<p>The \"Campus Map\" tab includes a map of the RPI campus, providing a succinct overview of its behavior.
Users can customize their searches using the following selections:</p>
<span style = 'padding-bottom: 6.9px; font-size: 1.2em;line-height: 1.6em;font-weight: 400;color: #6e6e6e;'>
<ui>
<li>Display Type: map or table</li>
<li>Date: Selecting which day to observe out of the past thirty days</li>
<li>Time: Selecting which time to observe on the selected date</li>
<li>Building: Selecting one building to stand out</li>
</ui>
</span>
<p>Based on the users selection the main panel will display either a geographic map or a table.
Color indicators are based on the percentage of calculated capacity.</p>
</div>
<h4 style = 'text-align: left'>Find a Place to Study </h4>
<div style='margin-left: 1%'>
<p>The \"Find a Place to Study\" is intended to be a go-to quicksearch of any building.
Users can customize their searches using the following selections:</p>
<span style = 'padding-bottom: 6.9px; font-size: 1.2em;line-height: 1.6em;font-weight: 400;color: #6e6e6e;'>
<ui>
<li>Date: Selecting which day to observe out of the past thirty days</li>
<li>Time: Selecting which time to observe on the selected date</li>
<li>Building: Selecting one building to observe</li>
</ui>
</span>
<p>Based on the users selection the main panel will display a graph, a recommendation,
and the summary of the analyses that led to that conclusion.</p>
</div>
<h4 style = 'text-align: left'>Quick Compare </h4>
<div style='margin-left: 1%'>
<p>The \"Quick Compare\" tab is intended to be a more in depth search, involving comparison of several locations on campus at once.
Users can customize their searches using the following selections:</p>
<span style = 'padding-bottom: 6.9px; font-size: 1.2em;line-height: 1.6em;font-weight: 400;color: #6e6e6e;'>
<ui>
<li>Date: Selecting which day to observe out of the past thirty days</li>
<li>Time: Selecting which time to observe on the selected date</li>
<li>Buildings: Selecting multiple buildings to observe and compare</li>
</ui>
</span>
<p>Based on the users selection the main panel will display graphs to display information about capacity limits,
and a concise comparitive analysis will be provided.</p>
</div>
<h4 style = 'text-align: left'>DISCLAIMERS</h4>
<div style='margin-left: 1%'>
<p>Some of the information displayed is approximated and/or may not be 100% accurate as it is an approximation of imperfect data.
Improvements to this application will continue to be made. </p>
</div>
")
),
hr(),
HTML("<footer text-align: center; '>
<h1 style = 'color:#990000; font-size: 1.5em;'>
<a href='https://idea.rpi.edu/'; style = 'color: #990000; background-color: #f7f7f7;'>About IDEA</a>
|
<a href='https://info.rpi.edu/web-privacy-statement'; style = 'color: #990000; background-color: #f7f7f7;'>Privacy Policy</a>
|
<a href='https://github.rpi.edu/DataINCITE/IDEA-COVID-StudySafe'; style = 'color: #990000; background-color: #f7f7f7;'>GitHub</a>
</h1>
</footer>")
),
#FIND A PLACE TO STUDY TAB
tabItem(tabName="find",
uiOutput("find_body"),
tags$div(HTML("<br></br>")),
#wellPanel(
tags$div(HTML("<h1 style = 'color: #ab2328'><b>Find a Place to Study</b></h1>")),
fluidRow(column(12, box(collapsible = TRUE, width = '100%', title= tags$div(HTML("<span style = 'color: #54585a '> <b>How to Use: </b>Find a Place to Study</span>")),
style = 'color:#54585a; background-color: white', solidHeader=TRUE,
HTML("<span style = 'font-size: 1.1em;'>
<li>Open and close the dashboard menu by clicking the hamburger icon</li>
<li>Select a building by using the drop-down selection or typing to search. </li>
<li>Then click “NOW!” or select a date and time to see the building’s user activity throughout the day</li>
<li>If you wish to see a different building or hour, change your selections and click “Update Graphs”</li>
<li>Note: Any number of users less than 10 is rounded to either 0 or 10</li>
</span>")))),
actionButton(inputId = "NOW_find", label = "NOW!", width = '100%', style = 'color: white; background-color: #990000; display:block; border-radius: 0%; border: 1px solid red;',
icon = icon("calendar"), block = TRUE),
inputPanel(dateInput('date', label = tags$div(HTML("<b><span style = 'color: #54585a'>Choose a Date</span></b>")), value = max_date, min = min_date, max = max_date),
selectInput('time', label = tags$div(HTML("<b><span style = 'color: #54585a'>Choose a Time</span></b>")), time),
fluidRow(column(pickerInput(inputId = 'building', label = tags$div(HTML("<b><span style = 'color: #54585a'>Choose a Building</span></b>")),
options = list(`live-search` = TRUE),
choices = byCat_single), width = 12),
column(prettySwitch(inputId = 'find_byActivity', inline = TRUE, label= tags$div(HTML("<b><span style = 'color: #54585a'>List by Activity</span></b>")), value = FALSE, status = "default", fill = TRUE, bigger = TRUE), width = 12)),
actionButton(inputId = "submit_find", label = "Update Graphs", icon = icon('refresh'), class = "btn-default btn-lg", style = ' color: #990000; background-color: white' ,block = TRUE)
),
tags$div(HTML("<br></br>")),
fluidRow(column(plotOutput("OneBuildingPerHour"), width=12) ),
tags$div(HTML("<br></br>")),
fluidRow(
column(tags$div(
h3(tags$b(htmlOutput('title_summary'), style = 'text-transform: uppercase;')),
h3(htmlOutput('AboveBelowAvg1_summary'), style = 'font-size: 1.4em;'),
h3(htmlOutput('AboveBelowAvg2_summary'), style = 'font-size: 1.4em;'),
h3(htmlOutput('capacity_summary'), style = 'font-size: 1.4em;'),
h3(htmlOutput('trend_summary'), style = 'font-size: 1.4em;'),
h3(htmlOutput("SmileFrown_summary"), style = 'font-size: 1.4em;'),
h3(htmlOutput("BuildingInfo"),style = 'font-size: 1.4em;')
),
width=12, align = 'center'),
column(tags$div(img(imageOutput('SmileFrown_image')), style = 'text-align:center;'), width = 4, offset = 4),
column(actionButton(inputId= "jump_to_glance", label = "Compare", icon = icon('building'),
style = 'color: white; font-size:130%; background-color: #990000; display:block; height: 60px; width: 160px; border-radius: 0%; border: 1px solid red;', block = TRUE),
align = 'center', width = 12)
),
hr(),
HTML("<footer text-align: center; '>
<h1 style = 'color:#990000; font-size: 1.5em;'>
<a href='https://idea.rpi.edu/'; style = 'color: #990000; background-color: #f7f7f7;'>About IDEA</a>
|
<a href='https://info.rpi.edu/web-privacy-statement'; style = 'color: #990000; background-color: #f7f7f7;'>Privacy Policy</a>
|
<a href='https://github.rpi.edu/DataINCITE/IDEA-COVID-StudySafe'; style = 'color: #990000; background-color: #f7f7f7;'>GitHub</a>
</h1>
</footer>")
#)
),
#Quick Compare TAB
tabItem(tabName="overview",
uiOutput("overview_body"),
tags$div(HTML("<br></br>")),
#wellPanel(
tags$div(
HTML("<h1 style = 'color: #ab2328'><b>Quick Compare</b></h1>")
),
fluidRow(column(12, box(collapsible = TRUE, width = '100%', title = tags$div(HTML("<span style = 'color: #54585a '> <b>How to Use: </b>Quick Compare</span>")), style = 'color:#54585a; background-color: white', solidHeader=TRUE,
HTML('<span style = "font-size: 1.1em;">
<li>Open and close the dashboard menu by clicking the hamburger icon</li>
<li>Select several buildings using the “Choose Buildings” drop-down selection or type to search</li>
<li>Then click “NOW!” or select a date and time to compare the user activity in each building</li>
<li>If you wish to see different buildings or hour, change your selections and click "Update Graphs"</li>
<li>Note: Any number of users less than 10 is rounded to either 0 or 10</li>
</span>')))),
actionButton(inputId = "NOW_overview", label = "NOW!", width = '100%', style = 'color: white; background-color: #990000; display:block; border-radius: 0%; border: 1px solid red;', icon = icon("calendar"), block = TRUE),
inputPanel(dateInput('overview_date', label = tags$div(HTML("<b><span style = 'color: #54585a'>Choose a Date</span></b>")),
value = max_date, min = min_date, max = max_date),
selectInput('overview_time', label = tags$div(HTML("<b><span style = 'color: #54585a'>Choose a Time</span></b>")), time),
fluidRow(column(pickerInput(inputId = "buildingGraph", label = tags$div(HTML("<b><span style = 'color: #54585a'>Choose Buildings</span></b>")),
choices = byCat_single, options = list(`live-search` = TRUE), multiple = TRUE), width = 12),
column(prettySwitch(inputId = 'overview_byActivity', inline = TRUE, label= tags$div(HTML("<b><span style = 'color: #54585a'>List by Activity</span></b>")), value = FALSE, status = "default", fill = TRUE, bigger = TRUE), width = 12)),
actionButton(inputId = "submit_campus", label = "Update Graphs", icon = icon('refresh'), class = "btn-default btn-lg", style = ' color: #990000; background-color: white' ,block = TRUE)
),
tags$div(HTML("<br></br>")),
fluidRow(column(plotOutput('multipleBuildinghistogram'),width= 12)),
tags$div(HTML("<br></br>")),
fluidRow(column(plotOutput('multipleBuildingPerHour'),width= 12)),
hr(),
HTML("<footer text-align: center; '>
<h1 style = 'color:#990000; font-size: 1.5em;'>
<a href='https://idea.rpi.edu/'; style = 'color: #990000; background-color: #f7f7f7;'>About IDEA</a>
|
<a href='https://info.rpi.edu/web-privacy-statement'; style = 'color: #990000; background-color: #f7f7f7;'>Privacy Policy</a>
|
<a href='https://github.rpi.edu/DataINCITE/IDEA-COVID-StudySafe'; style = 'color: #990000; background-color: #f7f7f7;'>GitHub</a>
</h1>
</footer>")
#)
),
#CAMPUS MAP TAB
tabItem(tabName="map",
tags$div(HTML("<br></br>")),
tags$div(
HTML("<h1 style = 'color: #ab2328'><b>Campus Map</b></h1>")
),
fluidRow(column(12, box(collapsible = TRUE, width = '100%', title = tags$div(HTML("<span style = 'color: #54585a; '> <b>How to Use: </b>Campus Map</span>")), style = 'color:#54585a; background-color: white', solidHeader=TRUE,
HTML('<span style = "font-size: 1.1em;">
<li>Open and close the dashboard menu by clicking the hamburger icon</li>
<li>Click “NOW!” or select a date and time to see the RPI campus map</li>
<li>For more information on that building, click on the marker to visit the Find a Place to Study tab</li>
<li>If you wish to see a different hour, change your selections and click “Update Graphs”</li>
<li>Note: Any number of users less than 10 is rounded to either 0 or 10</li>
</span>')))),
actionButton(inputId = "NOW_map", label = "NOW!", width = '100%', style = 'color: white; background-color: #990000; display:block; border-radius: 0%; border: 1px solid red;', icon = icon("calendar"), block = TRUE),
inputPanel(
selectInput('displaySelect', label = tags$div(HTML("<b><span style = 'color: #54585a'>Choose a Display</span></b>")), c('Map', 'Table')),
dateInput('map_date', label = tags$div(HTML("<b><span style = 'color: #54585a'>Choose a Date</span></b>")), value = max_date, min = min_date, max = max_date),
selectInput('map_time', label = tags$div(HTML("<b><span style = 'color: #54585a'>Choose a Time</span></b>")), time),
fluidRow(
column(pickerInput('map_building', inline = FALSE, label = tags$div(HTML("<b><span style = 'color: #54585a'>Choose a Building</span></b>")),
choices = byCat_multi,
selected = "None", multiple = FALSE, options = list(`live-search`=TRUE)), width = 12),
column(prettySwitch(inputId = 'map_byActivity', inline = TRUE, label= tags$div(HTML("<b><span style = 'color: #54585a'>List by Activity</span></b>")), value = FALSE, status = "default", fill = TRUE, bigger = TRUE), width = 12)),
actionButton(inputId = "submit_map", inline = TRUE, label = "Update Graphs", icon = icon('refresh'), class = "btn-default btn-lg", style = ' color: #990000; background-color: white', block = TRUE)
),
uiOutput("map_body"),
tags$div(HTML("<br></br>")),
fluidRow(column(h4(textOutput('MT_title_summary'), style = 'color: #d6001c'),width =12)),
tags$div(HTML("<br></br>")),
fluidRow(column(leafletOutput(outputId='mymap', width = "100%", height = 1000),width = 12)),
reactableOutput(outputId = 'mytable', width = '100%'),
hr(),
HTML("<footer text-align: center; '>
<h1 style = 'color:#990000; font-size: 1.5em;'>
<a href='https://idea.rpi.edu/'; style = 'color: #990000; background-color: #f7f7f7;'>About IDEA</a>
|
<a href='https://info.rpi.edu/web-privacy-statement'; style = 'color: #990000; background-color: #f7f7f7;'>Privacy Policy</a>
|
<a href='https://github.rpi.edu/DataINCITE/IDEA-COVID-StudySafe'; style = 'color: #990000; background-color: #f7f7f7;'>GitHub</a>
</h1>
</footer>")
)
),
#USING THE CSS FILE ARIELLE DEVELOPED
tags$script(HTML('
$(document).ready(function() {
$(\'head\').append(\'<link rel="stylesheet" href="" type="text/css" />\');
$(\'head\').append(\'<link rel="stylesheet" href="brand_style.css" type="text/css" />\');
$("header").find("nav").append(\'<p style="font-size: 200%; text-align: center;">RPI<b><span style = "color: #990000;"><span style="padding-left:2px; padding-right: 2px;">StudySafe</span></span></b></p>\');
// $(".sidebar-toggle").insertAfter(".tab-content");
})
')),
)
)
# Define server logic required
server <- function(input, output, session) {
#CONSISTENT INPUT SELECTION ACROSS ALL TABS
#Activity Tagging Switch consistent across all tabs
#Select Building choices dependent on Acitivity Tagging Switch
observe({
if (input$find_byActivity == FALSE) {
updatePickerInput(session, inputId = "building", choices = byCat_single)
} else {
updatePickerInput(session, inputId = "building", choices = byAct_single)
}
})
observe({
if (input$map_byActivity == FALSE) {
updatePickerInput(session, inputId = 'map_building', choices = byCat_multi)
} else {
updatePickerInput(session, inputId = 'map_building', choices = byAct_multi)
}
})
#Now button to current time
observeEvent(input$NOW_find, {
date_app$date <- max_date
time_app$time <- max_time_of_max_date-1
updateDateInput(session, "date", value = max_date)
updateSelectInput(session, "time", choices = time[1:max_time_of_max_date], selected = max_time_of_max_date-1)
})
# Jump to "Quick Compare"
observeEvent(input$jump_to_glance, {
# Switch to "Quick Compare"
newtab <- switch(input$tabs, "find" = "overview","overview" = "find")
updateTabItems(session, "tabs", newtab)
#Update everything (Date, time, and one of building multi-select)
updateDateInput(session, "overview_date", value = input$date)
updateSelectInput(session, "overview_time", choices = time, selected = input$time)
observe({
if (input$overview_byActivity == FALSE){
updatePickerInput(session, "buildingGraph", label = "Building Multiselect",
choices = byCat_single,
selected = input$building)
} else {
updatePickerInput(session, "buildingGraph", label = "Building Multiselect",
choices = byAct_single,
selected = input$building)
}
})
})
observe({
if (input$overview_byActivity == FALSE){
updatePickerInput(session, "buildingGraph", label = "Building Multiselect",
choices = byCat_single,
selected = input$building)
} else {
updatePickerInput(session, "buildingGraph", label = "Building Multiselect",
choices = byAct_single,
selected = input$building)
}
})
observe({
# Update the input in the "Find a Place to Study" tab consistently with the other tab
if (input$tabs == 'map' || input$tabs == 'overview') {
updateDateInput(session, "date", value = date_app$date)
updateSelectInput(session, "time", choices = time, selected = time_app$time)
}
# If user chooses minimum date we have, limit time selection range
if (input$date == min_date){
updateSelectInput(session, "time", choices = time[min_time_of_min_date:length(time)], selected = time_app$time)
}
# If user chooses maximum date we have, limit time selection range
else if (input$date == max_date){
updateSelectInput(session, "time", choices = time[1:max_time_of_max_date], selected = time_app$time)
}
# If user chooses date between maximum and minimum, then time should not be limited
else if (input$date != max_date & input$date != min_date){
updateSelectInput(session, "time", choices = time, selected = time_app$time)
}
})
counter_find <- reactiveValues(number = -1) # Number of "Update Graphs" button being clicked
#ABOUT TAB
output$about_body <- renderUI({})
#FIND A PLACE TO STUDY TAB
output$find_body <- renderUI({
# Observe whether "Update Graphs" button is clicked
observe({
if (input$submit_find == counter_find$number + 1){
date_app$date <- input$date
time_app$time <- input$time
building_selected$building <- input$building
counter_find$number <- counter_find$number + 1
}
})
date_select <- date_app$date
time_select <- time_app$time
building_select <- building_selected$building
#QUICK SEARCH WELL PANEL
#Piping the data to only have selected building at the selected date and time
quick1_filtered <- rpi_wap_last7 %>% filter(Date == date_select) %>% filter(Building == building_select)
#Calculations for above or below average compared to the rest of the day for the selected building
aggdf <- aggregate(quick1_filtered$users, by=list(quick1_filtered$Hour),FUN=sum)
colnames(aggdf) <- c('Hour','users')
aggdf$users[aggdf$users <= 5] <- 0 #making users per building under 5 exluding zero -> 0
aggdf$users[aggdf$users > 5 & aggdf$users <10 ] <- 10 #making users per building over 5 and under 10 -> 10
aggdf$users_z <- round((aggdf$users - mean(aggdf$users))/sd(aggdf$users), 2) # compute normalized hits per wap
aggdf$users_type <- ifelse(aggdf$users_z < 0, "below", "above") # above / below avg flag
#calculations for above/below average compared to the rest of the buildings at that time
quick2_filtered <- rpi_wap_last7 %>% filter(Date == date_select) %>% filter(Hour == time_select)
aggdf2 <- aggregate(quick2_filtered$users, by=list(quick2_filtered$Building),FUN=sum)
colnames(aggdf2) <- c('Building','users')
aggdf2$users[aggdf2$users <= 5] <- 0 #making users per building under 5 exluding zero -> 0
aggdf2$users[aggdf2$users > 5 & aggdf2$users <10 ] <- 10 #making users per building over 5 and under 10 -> 10
aggdf2$users_z <- round((aggdf2$users - mean(aggdf2$users))/sd(aggdf2$users), 2) # compute normalized hits per wap
aggdf2$users_type <- ifelse(aggdf2$users_z < 0, "below", "above") # above / below avg flag
output$BuildingInfo <- renderText({
if(building_select %in% buildinghoursAccessInfo$Building ){
#paste("You have selected" , building_select)
{stringr::str_c(building_select, "hours: ",buildinghoursAccessInfo[buildinghoursAccessInfo$Building == building_select, ]$TimeZone,
', Access:',
buildinghoursAccessInfo[buildinghoursAccessInfo$Building == building_select, ]$Mode, sep = " ")}
}
else{
paste("Building hours and access information for", building_select, "are not available at this time")
}
#paste("You have selected" , building_select)
})
#above/below average summary output
output$title_summary <- renderText({stringr::str_c('On', date_select, 'at', time.data[time.data$Time_num==time_select,]$Time_AMPM,',', building_select, ':', sep = " ")})
output$AboveBelowAvg1_summary <- renderText({
if(is.na(sd(aggdf$users))==TRUE){'Has no information about averages compared to earlier in the day at this time.'}else if(building_select %in% hits_per_wap_semester_by_building_max$Building & sd(aggdf$users) != 0 & (time_select %in% aggdf$Hour)){
stringr::str_c('Has<b>', aggdf[aggdf$Hour == time_select,]$users_type, 'average</b> users compared to earlier in the day', sep = " ")
}else if(building_select %in% hits_per_wap_semester_by_building_max$Building & sd(aggdf$users) == 0){'Has <b>no change</b> in users at all today.'}else{'Has no information about averages compared to earlier in the day at this time.'}
})
output$AboveBelowAvg2_summary <- renderText({
if(is.na(sd(aggdf2$users))==TRUE){'Has no information about averages compared to the rest of campus at this time.'}else if(building_select %in% hits_per_wap_semester_by_building_max$Building & sd(aggdf2$users) != 0 & (time_select %in% aggdf$Hour)){
stringr::str_c('Has<b>', aggdf2[aggdf2$Building==building_select,]$users_type, 'average</b> users compared to the rest of campus.', sep = " ")
}else if(building_select %in% hits_per_wap_semester_by_building_max$Building & sd(aggdf2$users) == 0){'Is <b>no different</b> from the rest of campus.'}else{'Has no information about averages compared to the rest of campus at this time.'}
})
if((time_select %in% aggdf$Hour) & (time_select != 0) & ((as.integer(time_select)-1) %in% aggdf$Hour)){
#Calculating trend by slope over 1 hour for that building at selected hour
trend1 <- aggdf[aggdf$Hour== as.integer(time_select),]$users
trend2 <- aggdf[aggdf$Hour== as.integer(time_select)-1,]$users
trend <- as.integer(trend1)-as.integer(trend2)
#trend summary output
output$trend_summary <- renderText({
if(trend>=10){stringr::str_c("Has <b>increased</b> by<b>",abs(trend),"users</b> in the past hour.", sep = " ")}else if(trend<=-10){
stringr::str_c("Has <b>decreased</b> by<b>",abs(trend),"users</b> in the past hour.", sep = " ")}else{
stringr::str_c("Has no significant change in the amount of users in the past hour.", sep = " ")
}
})
}else{output$trend_summary <- renderText("Has no information about trends at this time.")}
#calculations for OneBuildingPerHour plot
quick_plot <- rpi_wap_last7 %>% filter(Building == building_select ) %>% filter(Date == date_select)
aggdf3 <- aggregate(quick_plot$users, by=list(quick_plot$Hour, quick_plot$Building),FUN=sum)
colnames(aggdf3) <- c('Hour','Building','users')
aggdf3 <- aggdf3 %>% select(-Building)
aggdf3$users[aggdf3$users <= 5] <- 0 #making users per building under 5 exluding zero -> 0
aggdf3$users[aggdf3$users > 5 & aggdf3$users <10 ] <- 10 #making users per building over 5 and under 10 -> 10
#predictions for OneBuildingPerHour plot
if(time_select != 23 & date_select == max_date){
Hour <- c(max(aggdf3$Hour):23)
users <- rep(c(0), times = length(Hour))
prediction.template <- data.frame(Hour,users, stringsAsFactors=FALSE)
prediction.template[prediction.template$Hour == max(aggdf3$Hour),]$users <- aggdf3[aggdf3$Hour == max(aggdf3$Hour),]$users
avg.df <- weekly3_stats %>% filter(Building == building_select) %>% select(-Building) %>% filter(dayVal == wday(date_select)) %>% select(-dayVal)
colnames(avg.df) <- c('Hour', 'users')
for(i in c(max(aggdf3$Hour):22)){
prediction.template[prediction.template$Hour == (i+1),]$users <- round((prediction.template[prediction.template$Hour==(i),]$users+ avg.df[avg.df$Hour==(i+1),]$users)/2 )
}
}else{
prediction.template <- data.frame(c(0:23), rep(c(0), times = length(c(0:23))), stringsAsFactors=FALSE)
colnames(prediction.template) <- c('Hour', 'users')
}
#standard deviation bars
sd_calc <- rpi_wap_last7 %>% filter(Building == building_select) %>% select(Hour,users)
#shaded rectangles to improve legibility
rect_left <- c(0, 6, 12, 18)
rectangles <- data.frame(
xmin = rect_left,
xmax = rect_left + 3,
ymin = 0,
ymax = Inf
)
#OneBuildingPerHour plot output
output$OneBuildingPerHour <- renderPlot ({
ggplot(aggdf3, aes(x=Hour, y=users))+
#Grey Time Blocks
geom_rect(data=rectangles, inherit.aes = F, aes(xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax), fill='gray80', alpha=0.5) +
#Line at 0 to help legibility
geom_segment(aes(x= 0 ,xend=23,y=0,yend=0), colour=lightcolor, size=2) +
geom_histogram(stat="identity", fill = lightcolor, binwidth = .5) +
labs(title="Investigating Where to go", subtitle=stringr::str_c(building_select, " on ", date_select, " at ", time.data[time.data$Time_num==time_select,]$Time_AMPM ), y="Users", x = 'Time of Day',color=NULL) +
scale_y_continuous(expand = expansion(mult = c(0, .1))) +
scale_x_continuous(breaks= seq(0,23,1), labels=time.data$Time_noLabel) +
#Dark Blue Rectangle indicating selected Hour
geom_rect(fill = darkcolor, xmin = as.integer(time_select)-0.45, xmax = as.integer(time_select)+0.45, ymin = 0, ymax = aggdf3$users[as.integer(time_select)+1]) +
#Line indicating Max users
geom_hline(yintercept = hits_per_wap_semester_by_building_max[hits_per_wap_semester_by_building_max$Building==building_select,]$capacity, linetype = "dotted") +
annotate(geom="text", label= 'Max Users this Semester', x=11.5, y=hits_per_wap_semester_by_building_max[hits_per_wap_semester_by_building_max$Building==building_select,]$capacity, colour = "gray30",vjust=-0.5) +
geom_vline(xintercept = as.integer(time_select), size = 1.25, colour = '#54585a') +
#Adding bars of predicted data
geom_histogram(data = prediction.template[prediction.template$Hour>max(aggdf3$Hour),] , stat="identity", fill ="#FAFAFA", color = lightcolor, binwidth = .5) +
#Adding standard deviation error bars to predictive data
geom_errorbar(data = prediction.template[prediction.template$Hour>max(aggdf3$Hour),], aes(x=Hour, y=users, ymin = users,
ymax=users+sd(sd_calc[sd_calc$Hour %in% Hour,]$users)), colour=lightcolor, alpha=1, size=.8) +
#Theme
theme_bw() + theme(plot.background = element_blank(),
plot.title = element_text(family = 'Source Sans Pro', face = 'bold', lineheight = 6, size = 14, hjust = .5, color = '#d6001c', margin= margin( b = 8)),
plot.subtitle = element_text(family = 'Source Sans Pro', face = 'plain', size = 12, hjust = .5, color = '#54585a'),
axis.title = element_text(family = 'Source Sans Pro', face = 'plain', size = 12, hjust = .5, color = '#54585a')
)
}, bg="transparent")
#is the building near capacity for the selected time calculations
capacities <- hits_per_wap_semester_by_building_max %>% filter(Building==building_select)
cap_recommend <- aggdf
cap_recommend$users_action <- ifelse(cap_recommend$users <= .75*capacities$capacity, "below 75% maximum ", "near or above 75% maximum ") # above / below avg flag
cap_recommend$users_calc <- ifelse(cap_recommend$users <= .5*capacities$capacity, "below 50%", "above 50%") # above / below avg flag
#near capacity test output statement
output$capacity_summary <- renderText({
if(building_select %in% hits_per_wap_semester_by_building_max$Building & (time_select %in% aggdf$Hour) ){
stringr::str_c('Is<b> ', cap_recommend[cap_recommend$Hour==time_select,]$users_action, '</b>(about <b>', round(100*(cap_recommend[cap_recommend$Hour==time_select,]$users)/ capacities[capacities$Building==building_select,]$capacity,2) ,'% full</b>).',sep = "")
}else{'Has no information about capacity for this building at this time'}
})
#recommendation calculations
recnum <- 0
if(building_select %in% hits_per_wap_semester_by_building_max$Building){
if(cap_recommend[cap_recommend$Hour==time_select,]$users_action=='below 75% maximum ' & (time_select %in% aggdf$Hour)){recnum <- recnum + 1}else if(cap_recommend[cap_recommend$Hour==time_select,]$users_action=="near or above 75% maximum " & (time_select %in% aggdf$Hour)){recnum <- recnum - 1}else{}
if(cap_recommend[cap_recommend$Hour==time_select,]$users_calc=='below 50%' & (time_select %in% aggdf$Hour)){}else if(cap_recommend[cap_recommend$Hour==time_select,]$users_calc=="above 50%" & (time_select %in% aggdf$Hour)){recnum <- recnum - 0.5}else{}
if(is.na(sd(aggdf$users))==TRUE){}else if(sd(aggdf$users)==0){recnum <- recnum}else if(aggdf[aggdf$Hour==time_select,]$users_type=='above' & (time_select %in% aggdf$Hour)){recnum <- recnum - 0.75}else if(aggdf[aggdf$Hour==time_select,]$users_type=='below' & (time_select %in% aggdf$Hour)){recnum <- recnum + 0.75}else{}
if(is.na(sd(aggdf2$users))==TRUE){}else if(sd(aggdf2$users)==0){recnum <- recnum}else if(aggdf2[aggdf2$Building==building_select,]$users_type=='above' & (time_select %in% aggdf$Hour)){recnum <- recnum - 0.25}else if(aggdf2[aggdf2$Building==building_select,]$users_type=='below' & (time_select %in% aggdf$Hour)){recnum <- recnum + 0.25}else{}
}else{}
if((time_select %in% aggdf$Hour) & ((as.integer(time_select)-1) %in% aggdf$Hour) & (time_select != 0)){
if(trend>=10){renum<-recnum - 0.5}else{recnum <- recnum + 0.5}
}else{}
#recommendation text output
output$SmileFrown_summary <- renderText({
if((time_select %in% aggdf$Hour ) & recnum>1){
"<b><em>This might be a good spot!</em></b>"
}else if((time_select %in% aggdf$Hour) & recnum<0){"<b><em>This might not be a good spot right now.</em></b>"}
else{'<b><em>This may or may not be a good spot, maybe consider somewhere else first!</em></b>'}
})
#image output depending on reccommendation calculations
output$SmileFrown_image <- renderImage({
if((time_select %in% aggdf$Hour) & recnum>1){
filename <- normalizePath(file.path('images', paste('WithoutBlue', '.png', sep='')))
}else if((time_select %in% aggdf$Hour) & recnum<0){ filename <- normalizePath(file.path('images', paste('WithoutRed2', '.png', sep='')))}
else{filename <- normalizePath(file.path('images', paste('WithoutOrange2', '.png', sep='')))}
list(src = filename,
alt = "This is alternate text for the image (smile or frown) representing the reccommendation sentence")
},deleteFile = FALSE)
})
#QUICK COMPARE TAB
#Now button to current time
observeEvent(input$NOW_overview, {
date_app$date <- max_date
time_app$time <- max_time_of_max_date-1
updateDateInput(session, "overview_date", value = max_date)
updateSelectInput(session, "overview_time", choices = time, selected = max_time_of_max_date-1)
})
observeEvent(input$jump_to_glance, {
date_select = input$overview_date
time_select = input$overview_time
buildings_select = input$buildingGraph
})
observe({
# Update the input in the "Quick Compare" tab consistently with the other tab
if (input$tabs == 'find' || input$tabs == 'map') {
updateDateInput(session, "overview_date", value = date_app$date)
updateSelectInput(session, "overview_time", choices = time, selected = time_app$time)
}
# If user chooses minimum date we have, restrict time selection range
if (input$overview_date == min_date){
updateSelectInput(session, "overview_time", choices = time[min_time_of_min_date:length(time)], selected = date_app$date)
}
# If user chooses maximum date we have, restrict time selection range
else if (input$overview_date == max_date){
updateSelectInput(session, "overview_time", choices = time[1:max_time_of_max_date], selected = time_app$time)
}
# If user chooses date between maximum and minimum, then time should not be constrained
else if (input$overview_date != max_date & input$overview_date != min_date){
updateSelectInput(session, "overview_time", choices = time, selected = time_app$time)
}
})
#The remaining body
output$overview_body <-renderUI({
# When first open it, nothing to show
if (input$submit_campus == 0 & is.null(input$jump_to_glance))
return(NULL)
# Isolate updating inputs so that the graph will update only if user clicks "Update Graphs"
isolate({
date_app$date <- input$overview_date
time_app$time <- input$overview_time
buildings_select <- input$buildingGraph
})
date_select <- date_app$date
time_select <- time_app$time
#Wes Anderson "Darjeeling1" Palette
pal <- wes_palette("Darjeeling1", length(buildings_select), type = "continuous")
#calculations for multipleBuildingPerHour plot
multi_plot <- rpi_wap_last7 %>% filter(Building %in% buildings_select) %>% filter(Date == date_select)
aggdf4 <- aggregate(multi_plot$users, by=list(multi_plot$Hour, multi_plot$Building),FUN=sum)
colnames(aggdf4) <- c('Hour','Building','users')
aggdf4$users[aggdf4$users <= 5] <- 0 #making users per building under 5 exluding zero -> 0
aggdf4$users[aggdf4$users > 5 & aggdf4$users <10 ] <- 10 #making users per building over 5 and under 10 -> 10
cap_select <- hits_per_wap_semester_by_building_max %>% filter(Building %in% buildings_select)
aggdf4$percentage <- 0
for(building in cap_select$Building){
for(i in 0:23){
aggdf4[aggdf4$Hour== i & aggdf4$Building==building, ]$percentage <- 100*(aggdf4[aggdf4$Hour== i & aggdf4$Building==building, ]$users/cap_select[cap_select$Building==building,]$capacity)
}
}
#shaded rectangles to improve legibility
rect_left <- c(0, 6, 12, 18)
rectangles <- data.frame(
xmin = rect_left,
xmax = rect_left + 3,
ymin = 0,
ymax = Inf
)
#Multiple Building per Hour Plot
output$multipleBuildingPerHour <- renderPlot({
ggplot(aggdf4, aes(x=Hour)) +
#Grey Time Blocks
geom_rect(data=rectangles, inherit.aes = F,
aes(xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax),
fill='gray80', alpha=0.2) +
geom_line(aes(y=percentage, col=Building)) + scale_color_brewer(palette = "RdYlBu")+
labs(title= "Investigating Where to Go",
subtitle=paste("Selected Buildings on", date_select, "at", time.data[time.data$Time_num==time_select,]$Time_AMPM ),
y="Percentage of Maximum Users", x = "Time of Day",
color=NULL) + scale_x_continuous(breaks= seq(0,23,1), labels=time.data$Time_noLabel) + scale_y_continuous(breaks= seq(0,100,5)) +
geom_vline(xintercept = as.integer(time_select), size = 1.25, colour = '#54585a') +
scale_color_manual(values = pal) +
#Theme
theme_bw() + theme(plot.background = element_blank(),
plot.title = element_text(family = 'Source Sans Pro', face = 'bold', lineheight = 6, size = 14, hjust = .5, color = '#d6001c', margin= margin( b = 8)),
plot.subtitle = element_text(family = 'Source Sans Pro', face = 'plain', size = 12, hjust = .5, color = '#54585a'),
axis.title = element_text(family = 'Source Sans Pro', face = 'plain', size = 12, hjust = .5, color = '#54585a'),
legend.background = element_blank(),
legend.position = "bottom",
legend.text = element_text(family = 'Source Sans Pro', face = 'plain', color = '#54585a')
)
}, bg = "transparent")
# Select the specific hour (user input) data out
Builings_specific_hour2 <- aggdf4[aggdf4$Hour == time_select,]
# The data frame of maximum urses of every building for this semester
Buildings_selected_capacity <- hits_per_wap_semester_by_building_max[hits_per_wap_semester_by_building_max$Building %in% Builings_specific_hour2$Building,]
# Combine maximum urses(capacity here) of each building and the data we have
Builings_specific_hour <- cbind(Builings_specific_hour2, capacity = rep(0,nrow(Builings_specific_hour2)))
Builings_specific_hour$capacity[Builings_specific_hour$Building %in% Buildings_selected_capacity$Building] <- Buildings_selected_capacity$capacity
# Split into two data frames in order to draw two histograms(one is capacity, the other is number of users now) in one graph
true_users <- data.frame(Building = Builings_specific_hour$Building, users = Builings_specific_hour$users)
max_capacity <- data.frame(Building = Builings_specific_hour$Building, users = Builings_specific_hour$capacity)
# Plot the histogram graph
output$multipleBuildinghistogram <- renderPlot({
ggplot(Builings_specific_hour,aes(x = Building, y = users, color = as.factor(Building), fill = as.factor(Building))) +
geom_histogram(data = true_users, stat='identity', alpha=0.6) + geom_histogram(data = max_capacity, fill = 'white', stat='identity', alpha=0.6, label = TRUE) +
geom_text(aes(label = percent(users/capacity)), position = position_stack(vjust = 1), size=5) +
labs(title="Investigating Where to Go",
subtitle=paste("Selected Buildings on", date_select, "at", time.data[time.data$Time_num==time_select,]$Time_AMPM ),
y="Users Compared to Maximum", x = "Selected Buildings",
color = 'Buildings',
fill = 'Buildings'
) +
scale_color_manual(values = pal) + scale_fill_manual(values = pal) +
#Theme
theme_bw() + theme(plot.background = element_blank(),
plot.title = element_text(family = 'Source Sans Pro', face = 'bold', lineheight = 6, size = 14, hjust = .5, color = '#d6001c', margin= margin( b = 8)),
plot.subtitle = element_text(family = 'Source Sans Pro', face = 'plain', size = 12, hjust = .5, color = '#54585a'),
axis.title = element_text(family = 'Source Sans Pro', face = 'plain', size = 12, hjust = .5, color = '#54585a'),
legend.background = element_blank(),
legend.position = "bottom",
legend.text = element_text(family = 'Source Sans Pro', face = 'plain', color = '#54585a'),
legend.title = element_blank()
)
}, bg = "transparent")
})
#MAP TAB BODY
counter_map <- reactiveValues(number = -1) # Number of "Update Graphs" button being clicked
#Now button to current time
observeEvent(input$NOW_map, {
date_app$date <- max_date
time_app$time <- max_time_of_max_date-1
updateDateInput(session, "map_date", value = max_date)
updateSelectInput(session, "map_time", choices = time[1:max_time_of_max_date], selected = max_time_of_max_date-1)
})
observe({
# Update the input in the "Map" tab consistently with the other tab
if (input$tabs == 'find' || input$tabs == 'overview') {
updateDateInput(session, "map_date", value = date_app$date)
updateSelectInput(session, "map_time", choices = time, selected = time_app$time)
}
# If user chooses minimum date we have, restrict time selection range
if (input$map_date == min_date){
updateSelectInput(session, "map_time", choices = time[min_time_of_min_date:length(time)], selected = time_app$time)
}
# If user chooses maximum date we have, restrict time selection range
else if (input$map_date == max_date){
updateSelectInput(session, "map_time", choices = time[1:max_time_of_max_date], selected = time_app$time)
}
# If user chooses date between maximum and minimum, then time should not be constrained
else if (input$map_date != max_date & input$map_date != min_date){
updateSelectInput(session, "map_time", choices = time, selected = time_app$time)
}
})
#The remaining body
jump_find <- 'no' # Jump to "Find a Place to Study" when this jump = 'yes'
building_map <- reactiveValues(building = 'none') # Temporarily remember the name of building that is clicked
output$map_body <- renderUI({
# Observe whether "Update Graphs" button is clicked
observe({
if (input$submit_map == counter_map$number + 1){
date_app$date <- input$map_date
time_app$time <- input$map_time
counter_map$number <- counter_map$number + 1
}
})
date_select <- date_app$date
time_select <- time_app$time
MTpreference <- input$displaySelect
#Title output
output$MT_title_summary <- renderText({
stringr::str_c("RPI on ", date_select,' at ', time.data[time.data$Time_num==time_select,]$Time_AMPM)
})
#Creating a data set for the map and table
map_merge_filtered <- rpi_wap_last7 %>% filter(Date == date_select) %>% filter(Hour==time_select) %>%
select(lat, lng, BuildingType,Building, users) %>% group_by(lat, lng, BuildingType,Building) %>% dplyr::summarise(totalusers = sum(users))
map_merge_filtered$totalusers[map_merge_filtered$totalusers <= 5] <- 0 #making users per building under 5 exluding zero -> 0
map_merge_filtered$totalusers[map_merge_filtered$totalusers > 5 & map_merge_filtered$totalusers <10 ] <- 10 #making users per building over 5 and under 10 -> 10
# Combine our data with capacity
map_merge_filtered2 <- merge(map_merge_filtered, hits_per_wap_semester_by_building_max, by.x= "Building", by.y="Building")
map_merge_filteredT <- map_merge_filtered2
# If user select a building, then remember info of that building as building_map_select and delete it from map_merge_filtered2
if (input$map_building != 'None'){
building_map_select <- map_merge_filtered2[map_merge_filtered2$Building == input$map_building,]
map_merge_filtered2 <- map_merge_filtered2[-c(which(map_merge_filtered2$Building == input$map_building)),]
}
# Get color of marker according to percentage of "capacity"
getColor <- function(map_merge_filtered2) {
mapply(function(totalusers, capacity) {
if(totalusers <= 0.25*capacity) {
"lightblue"
#"#1f6798" #light blue
} else if(totalusers <= 0.5*capacity) {
"beige"
#"#00205b" #dark blue
} else if(totalusers <= 0.75*capacity) {
"lightred"
#"#333366" #purple
}else {
"red"
#"#990000" #red
} }, map_merge_filtered2$totalusers, map_merge_filtered2$capacity
)
}
icons <- awesomeIcons(
icon = 'ios-close',
iconColor = 'black',
library = 'ion',
markerColor = getColor(map_merge_filtered2)
)
#Hiding whichever display is not selected, map or table
observeEvent(MTpreference, {
if(MTpreference=='Map'){
hideElement(id = 'mytable', anim = FALSE)
showElement(id = 'mymap')
}else if(MTpreference == 'Table'){
hideElement(id = 'mymap', anim = FALSE)
showElement(id = 'mytable')
}
})
#creating table
#Add percentage column
map_merge_filteredT$percentage <- percent(map_merge_filteredT$totalusers/map_merge_filteredT$capacity)
# Copy the dataframe map_merge_filteredT to another dataframe map_merge_filteredT_2
map_merge_filteredT_2 <- map_merge_filteredT
# shinyInput function to make action links
shinyInput <- function(FUN, len, id, label, ...) {
inputs <- character(len)
for (i in seq_len(len)) {
label <- map_merge_filteredT$Building[i]
inputs[i] <- as.character(FUN(paste0(id, i),label=label, ...))
}
inputs
}
# Add action links to Buildings' name
map_merge_filteredT <- map_merge_filteredT %>%
mutate(Building = shinyInput(actionLink, nrow(map_merge_filteredT), 'button_', label = Building, onclick = 'Shiny.onInputChange(\"jump_to_find_table\", this.id)' ))
output$mytable <- renderReactable({
reactable(
map_merge_filteredT,
#groupBy = "BuildingType",
pagination = FALSE,
height = 750,
#paginationType = "jump",
#showPageSizeOptions = TRUE,
#pageSizeOptions = c(5, 10, 25, 50, 100),
highlight = TRUE,
outlined = TRUE,
bordered = TRUE,
striped = TRUE,
compact = TRUE,
wrap = TRUE,
showSortable = TRUE,
resizable = TRUE,
searchable = TRUE,
style = 'color: black; background-color:#FAFAFA; font-family: Source Sans Pro;',
defaultSortOrder = "desc",
#highlighting a row if searched using input select
rowStyle = function(index) {
if (map_merge_filteredT_2[index, "Building"] == input$map_building) {
list(background = '#9ea2a2')}},
#listing BuildingType under Building names
columns = list(
Building = colDef(
style = 'text-align: left;',
# Show BuildingType under Building names
cell = JS("function(cellInfo) {
var BuildingType = cellInfo.row['BuildingType'] || 'Unknown'
return (
'<div style=\"font-weight: 600\">' + cellInfo.value + '</div>' +
'<div style=\"font-size: 12px\">' + BuildingType + '</div>'
)}"),html = TRUE),
lat = colDef(show = FALSE),
lng = colDef(show = FALSE),
BuildingType = colDef(show = FALSE),
totalusers = colDef(name = "Total Number of Users", align = 'left', style = 'text-align: right;'),
capacity = colDef(show = FALSE),
percentage = colDef(name = "Percentage of Max", format = colFormat(percent = TRUE), align = 'right', style = 'text-align: right;')
),
columnGroups = list(
colGroup(name = '', columns = c("Building", "BuildingType", "totalusers", "capacity", "percentage"),
headerStyle = 'color: white; background-color: black;'))
)
})
# When the action link(building's name) is clicked, jump to "Find a Place to Study"
observeEvent(input$jump_to_find_table, {
# The index of row that is clicked by the user
selectedRow <- as.numeric(strsplit(input$jump_to_find_table, "_")[[1]][2])
# To make sure that if user go back to map after jumping to "Find a Place to Study", system will not jump back to "Find a Place to Study"
if(map_merge_filteredT_2[selectedRow,]$Building != building_selected$building){
# Switch to "Find a Place to Study"
newtab <- switch(input$tabs, "map" = "find","find" = "map")
updateTabItems(session, "tabs", newtab)
# Update building selected of "Find a Place to Study"
updateSelectInput(session, "building",
choices = byCat_single,
selected = map_merge_filteredT_2[selectedRow,]$Building)
building_selected$building <- map_merge_filteredT_2[selectedRow,]$Building
}
})
#displaying the resulting map
map <- leaflet(map_merge_filtered2) %>%
addAwesomeMarkers(icon=icons,popup = ~paste0("Building: ", map_merge_filtered2$Building, "<br>", "Total number of Users: ", map_merge_filtered2$totalusers, "<br>",
"Percentage of Capacity: ", percent(map_merge_filtered2$totalusers/map_merge_filtered2$capacity),"<br>", "Learn more about ", "<b>", map_merge_filtered2$Building, "</b>",
" click ", actionLink(inputId = "jump_to_find", label = "here", onclick = 'Shiny.setInputValue(\"link1\", this.id, {priority: \"event\"})'))) %>%
addTiles() %>%setView( lng = -73.6789, lat = 42.7298, zoom = 16 ) %>%
#%>% addControl(map_title, position = "topright", className="map-title") %>%
addLegend(position = "topleft", colors = c("#00BFFF", "orange", "#FF6347", "red"), labels = c("0% ~ 25%", "25% ~ 50%", "50% ~ 75%", "75% ~ 100%"))
# If user selects a building, then add star icon at that building's position and star legend
if (input$map_building != 'None') {
# Using different color of star as icon and legend according to percentage of capacity
if (building_map_select$totalusers <= 0.25*building_map_select$capacity){
icon_url <- "images/blue_star.png"
html_legend <- "<img src='blue_star.png' style='width:20px;height:20px;'> Place of Selection <br/>"
}
else if (building_map_select$totalusers <= 0.5*building_map_select$capacity){
icon_url <- "images/beige_star.png"
html_legend <- "<img src='beige_star.png' style='width:20px;height:20px;'> Place of Selection <br/>"
}
else if (building_map_select$totalusers <= 0.75*building_map_select$capacity){
icon_url <- "images/lightred_star.png"
html_legend <- "<img src='lightred_star.png' style='width:20px;height:20px;'> Place of Selection <br/>"
}
else {
icon_url <- "images/darkred_star.png"
html_legend <- "<img src='darkred_star.png' style='width:20px;height:20px;'> Place of Selection <br/>"
}
# Make star icon
star_icon <- makeIcon(
iconUrl = icon_url,
iconWidth = 40, iconHeight= 40, iconAnchorX= 33*215/230/2, iconAnchorY = 16
)
# Add icon and legend
map <- map %>% addMarkers(icon=star_icon,lng = building_map_select$lng, lat = building_map_select$lat,popup = ~paste0("Building: ", building_map_select$Building, "<br>", "Total number of Users: ", building_map_select$totalusers, "<br>",
"Percentage of Capacity: ", percent(building_map_select$totalusers/building_map_select$capacity),"<br>", "Learn more about ", "<b>", building_map_select$Building, "</b>",
" click ", actionLink(inputId = "jump_to_find", label = "here", onclick = 'Shiny.setInputValue(\"link1\", this.id, {priority: \"event\"})'))) %>%
addControl(html = html_legend, position = "topleft")
}
output$mymap <- renderLeaflet({map})
# If the action link is not clicked, return nothing
if (is.null(input$link1))
return()
# Isolate everything so that they just excute when user clicks the link
isolate({
# To determine name of building that is clicked
marker_info <- input$mymap_marker_click
# marker_info just has latitude and longitude so we need to pair them with our data to find the name of building
marker_building <- map_merge_filtered[map_merge_filtered$lat == marker_info$lat,]
marker_building <- marker_building[marker_building$lng == marker_info$lng,]
# To make sure that if user go back to map after jumping to "Find a Place to Study", system will not jump back to "Find a Place to Study"
if(building_map$building != marker_building$Building)
{
jump_find <- 'yes'
building_map$building <- marker_building$Building
}
})
# If jump$find = yes, jump to "Find a Place to Study" and update everything
if (jump_find == 'yes') {
# Switch to "Find a Place to Study"
newtab <- switch(input$tabs, "map" = "find","find" = "map")
updateTabItems(session, "tabs", newtab)
# Update building selected of "Find a Place to Study"
updateSelectInput(session, "building",
choices = byCat_single,
selected = marker_building$Building)
building_selected$building <- marker_building$Building
jump_find <- 'no'
}
})
##INITIAL POP-UP WARNING
# Content of modal dialog
query_modal <- modalDialog(
title = tags$div(HTML("<h2><span style = 'color: #54585a; text-transform: capitalize;'>Welcome to RPI</span><b><span style = 'color: #990000; text-transform: capitalize;' > StudySafe</span></b></h2>")),
tags$div(HTML("<span style = 'font-weight: 400;color: #6e6e6e;'>
<p><b>WARNING:</b> The StudySafe application represents experimental, student-created work. Reasonable
effort has been made to provide a safe, informative, enjoyable user experience, but
some StudySafe application features may not comply with Web Content Accessibility Guidelines (WCAG).
<i>Use at your own risk.</i></p>
</span> ")),
easyClose = F,
footer = tagList(
actionButton("run", "Continue to StudySafe", style = ' color: white; background-color:#990000')
)
)
# Creates modal dialog
showModal(query_modal)
# Removes modal
observeEvent(input$run, {
removeModal()
})
}
# Run the application
shinyApp(ui = ui, server = server)