Related
I'm putting together a shiny app to play around with some athlete GPS data. Essentially, I'm looking to structure my script so that each time the user selects an area of interest on the plotly plot and the "Add" actionButton is clicked, the table below will add the calculated Start_time, Time_at_peak, Max_velocity, Time_to_peak, and Distance_to_peak values.
The issue can be seen in the GIF below: - Once the area of interest is selected and the "Add" button clicked, the first values seem correct. However, when the user selects a second area of interest to add to the table, it overwrites the initial entry and will keep overwriting each time a new selection is made. This is seemingly because because the code is inside the observeEvent(event_data("plotly_selected"), which, confusingly, it needs to be in order to calculate the variables of interest.
I'm currently a little stumped and can't seem to find any relevant information. As such, any guidance would be greatly appreciated!
Here is a we transfer link to some test data that can be uploaded to the app: https://wetransfer.com/downloads/5a7c5da5a7647bdbe133eb3fdac79c6b20211119052848/afe3e5
library(shiny)
library(readr)
library(DT)
library(dplyr)
library(plotly)
library(lubridate)
library(tidyr)
library(purrr)
library(htmlwidgets)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
x_df <- data.frame(Start_time = character(1), Time_at_peak = character(1), Max_velocity = integer(1),
Time_to_peak = integer(1), Distance_to_peak = integer(1))
x_df$Start_time <- as.character("0:00:00.0")
x_df$Time_at_peak <- as.character("0:00:00.0")
x_df$Max_velocity <- as.integer(0)
x_df$Time_to_peak <- as.integer(0)
x_df$Distance_to_peak <- as.integer(0)
runApp(shinyApp(
ui=(fluidPage(
titlePanel("Event to Table"),
mainPanel(
fileInput(
inputId = "filedata",
label = "Upload data file (.csv)",
accept = c(".csv")),
plotlyOutput('myPlot'),br(),br(),br(),br(),
DTOutput("testing"), br(), br(),
fluidRow(
valueBoxOutput("starttime", width = 2),
valueBoxOutput("endtime", width = 2),
valueBoxOutput("maxvelocity", width = 2),
valueBoxOutput("timediff", width = 3),
valueBoxOutput("distance", width = 3)
),
useShinyjs(),
fluidRow(
div(style = "text-align:center", actionButton("Add", "Add Data to Table"),
downloadButton("export", "Export Table as .CSV"))), br(),
DTOutput(outputId = "table")))
),
server = (function(input, output, session) {
data<-reactive({
req(input$filedata)
read.csv(input$filedata$datapath, header = TRUE)%>%
rename(Velocity = 'Speed..m.s.',
Player = 'Player.Display.Name',
Latitude = 'Lat',
Longtitude = 'Lon',
AccelImpulse = 'Instantaneous.Acceleration.Impulse',
HeartRate = 'Heart.Rate..bpm.')
})
observe({
thedata<-data()
updateSelectInput(session, 'y', choices = names(data))
})
output$myPlot = renderPlotly({
plot_ly(data = data(), x = ~Time, y = ~Velocity, height = 450,
marker =list(color = 'rgb(132,179,202)', size = 0.1),
line = list(color = 'rgb(132,179,202)', size = 0.1, width = 0.9),
type = 'scatter', mode = 'markers+lines') %>%
layout(dragmode = "select",
showlegend = F,
title = list(text = 'Velocity Trace', font = list(size = 20)),
xaxis = list(title = list(text = "", standoff = 0), nticks = 10),
yaxis = list(title = list(text = "Velocity (m/s)"), nticks = 5, gridcolor = "#46505a"),
font = list(color = 'black'),
margin = list(t = 70))
})
observeEvent(event_data("plotly_selected"), {
event.data <- event_data("plotly_selected")
if (max(event.data$y) < 1.5) {
maxvel <- (max(event.data$y))
maxpos <- match(maxvel, event.data$y)
}
else {
filter1 <- filter (event.data, event.data$y > 1.5)
maxvel <- (max(filter1$y))
maxpos <- match(maxvel, event.data$y)
}
zero_val <- function(x) x == 0
zero_index <- event.data$y[1:maxpos] %>% detect_index(zero_val, .dir = "backward")
if (zero_index==0) {starttime <- event.data$x[1]}
else {starttime <- event.data$x[zero_index]}
endvel <- which.max(event.data$y)
endtime <- event.data$x[endvel]
timediff <- paste(today(), endtime) %>% as_datetime() - paste(today(), starttime) %>% as_datetime()
sprint <- as_tibble(event.data$y[zero_index:endvel])
ms <- as_tibble(rep(0.1, count(sprint)))
time_vel <- cbind(ms, sprint)
distance <- sum(time_vel[1]*time_vel[2])
sprintselect <- as_tibble(cbind(Start_time = starttime,
Time_at_peak = endtime,
Max_velocity = round(maxvel, 2),
Time_to_peak = round(timediff, 1),
Distance_to_peak = round(distance, 1)))
values <- reactiveValues()
values$df <- x_df
addData <- observe({
if(input$Add > 0) {
newLine <- isolate(data.frame(Start_time = sprintselect$Start_time, Time_at_peak = sprintselect$Time_at_peak,
Max_velocity = sprintselect$Max_velocity,
Time_to_peak = sprintselect$Time_to_peak,
Distance_to_peak = sprintselect$Distance_to_peak,
stringsAsFactors= FALSE))
values$df <- isolate(rbind(values$df, newLine))}
})
output$testing <- renderDataTable({values$df})
})
})
))
I've managed to figure it out and thought I'd post an answer rather than delete the question - just in case someone out there is looking to do a similar thing and they are unsure how to do it.
Firstly, I removed the pre-populated table x_df from the beginning - it was no longer required.
Although I thought the code needed to sit inside the observeEvent(event_data("plotly_selected") to function correctly, it did not - thankfully, because that was at the root of the issue. Instead, I used observeEvent(input$Add, { (which is the correct code to use as opposed to if(input$Add > 0)) to anchor the event to the click of the Add button.
The values <- reactiveValues() was placed outside the observeEvent() and an IF statement was used to either add the data to the values$df data frame on it's own if it was the first selection, or bind it to the existing saved data.
Here's the new code and a GIF demonstrating.
library(shiny)
library(readr)
library(DT)
library(dplyr)
library(plotly)
library(lubridate)
library(tidyr)
library(purrr)
library(htmlwidgets)
library(shinydashboard)
library(dashboardthemes)
library(shinyjs)
runApp(shinyApp(
ui=(fluidPage(
titlePanel("Event to Table"),
mainPanel(
fileInput(
inputId = "filedata",
label = "Upload data file (.csv)",
accept = c(".csv")),
plotlyOutput('myPlot'),br(),br(),br(),br(),
DTOutput("testing"), br(), br(),
fluidRow(
valueBoxOutput("starttime", width = 2),
valueBoxOutput("endtime", width = 2),
valueBoxOutput("maxvelocity", width = 2),
valueBoxOutput("timediff", width = 3),
valueBoxOutput("distance", width = 3)
),
useShinyjs(),
fluidRow(
div(style = "text-align:center", actionButton("Add", "Add Data to Table"),
downloadButton("export", "Export Table as .CSV"))), br(),
DTOutput(outputId = "table")))
),
server = (function(input, output, session) {
values <- reactiveValues(df_data = NULL)
data<-reactive({
req(input$filedata)
read.csv(input$filedata$datapath, header = TRUE)%>%
rename(Velocity = 'Speed..m.s.',
Player = 'Player.Display.Name',
Latitude = 'Lat',
Longtitude = 'Lon',
AccelImpulse = 'Instantaneous.Acceleration.Impulse',
HeartRate = 'Heart.Rate..bpm.')
})
observe({
thedata<-data()
updateSelectInput(session, 'y', choices = names(data))
})
output$myPlot = renderPlotly({
plot_ly(data = data(), x = ~Time, y = ~Velocity, height = 450,
marker =list(color = 'rgb(132,179,202)', size = 0.1),
line = list(color = 'rgb(132,179,202)', size = 0.1, width = 0.9),
type = 'scatter', mode = 'markers+lines') %>%
layout(dragmode = "select",
showlegend = F,
title = list(text = 'Velocity Trace', font = list(size = 20)),
xaxis = list(title = list(text = "", standoff = 0), nticks = 10),
yaxis = list(title = list(text = "Velocity (m/s)"), nticks = 5, gridcolor = "#46505a"),
font = list(color = 'black'),
margin = list(t = 70))
})
observeEvent(input$Add, {
event.data <- event_data("plotly_selected")
if (max(event.data$y) < 1.5) {
maxvel <- (max(event.data$y))
maxpos <- match(maxvel, event.data$y)
}
else {
filter1 <- filter (event.data, event.data$y > 1.5)
maxvel <- (max(filter1$y))
maxpos <- match(maxvel, event.data$y)
}
zero_val <- function(x) x == 0
zero_index <- event.data$y[1:maxpos] %>% detect_index(zero_val, .dir = "backward")
if (zero_index==0) {starttime <- event.data$x[1]}
else {starttime <- event.data$x[zero_index]}
endvel <- which.max(event.data$y)
endtime <- event.data$x[endvel]
timediff <- paste(today(), endtime) %>% as_datetime() - paste(today(), starttime) %>% as_datetime()
sprint <- as_tibble(event.data$y[zero_index:endvel])
ms <- as_tibble(rep(0.1, count(sprint)))
time_vel <- cbind(ms, sprint)
distance <- sum(time_vel[1]*time_vel[2])
sprintselect <- as_tibble(cbind(Start_time = starttime,
Time_at_peak = endtime,
Max_velocity = round(maxvel, 2),
Time_to_peak = round(timediff, 1),
Distance_to_peak = round(distance, 1)))
newLine <- isolate(data.frame(Start_time = sprintselect$Start_time, Time_at_peak = sprintselect$Time_at_peak,
Max_velocity = sprintselect$Max_velocity,
Time_to_peak = sprintselect$Time_to_peak,
Distance_to_peak = sprintselect$Distance_to_peak,
stringsAsFactors= FALSE))
if (is.null(values$df)){
values$df <- newLine}
else {
values$df <- isolate(rbind(values$df, newLine))}
output$testing <- renderDataTable({values$df})
})
})
))
I am building a shiny budgeting shiny application that prompts the user to enter data such as what type of expense was spent, the amount, and a description. I would like to display a line plot in the second pannel of the application labeled "Monthly Budget" ONLY when the user has entered at least one data entry where the category is "Savings". I have tried experimenting with things such as hiding/displaying the plot whenever the condition is met, but it seems that I always get a NaN error message with this approach. Thus, I am experimenting with conditionalPanel() in hopes of accomplishing this task. I've noticed similar posts to this one, however this is the first case that I have found where conditionalPanel() deals with data that the user inputs as opposed to a given dataset. In the code below I get the following error message: "Error in: Invalid input: date_trans works with objects of class Date only".
Here is the code:
# Libraries
library(shiny)
library(ggplot2)
library(shinycssloaders)
library(colortools)
library(shinythemes)
library(DT)
library(tidyverse)
library(kableExtra)
library(formattable)
library(xts)
# Creating Contrasting Colors For Buckets
bucket_colors <- wheel("skyblue", num = 6)
# Define UI for application that draws a histogram
ui <- fluidPage(
# theme = shinytheme("spacelab"),
shinythemes::themeSelector(),
## Application Title
titlePanel("2021 Budgeting & Finances"),
tags$em("By:"),
tags$hr(),
navbarPage("", id = "Budget",
tabPanel("Data Entry",
div(class = "outer",
# Sidebar Layout
sidebarLayout(
sidebarPanel(
selectInput("Name",
label = "Name:",
choices = c("","Jack", "Jill")),
selectInput("Bucket",
label = "Item Bucket:",
choices = c("","Essential", "Non-Essential", "Savings", "Rent/Bills", "Trip", "Other")),
textInput("Item",
label = "Item Name:",
placeholder = "Ex: McDonald's"),
shinyWidgets::numericInputIcon("Amount",
"Amount:",
value = 0,
step = 0.01,
min = 0,
max = 1000000,
icon = list(icon("dollar"), NULL)),
dateInput("Date",
label = "Date",
value = Sys.Date(),
min = "2021-05-01",
max = "2022-12-31",
format = "M-d-yyyy"),
actionButton("Submit", "Submit", class = "btn btn-primary"),
downloadButton("Download", "Download")),
# Show a plot of the generated distribution
mainPanel(
tableOutput("PreviewTable")
)
)
)
),
############ THIS IS WHERE THE ERROR HAPPENS #############
tabPanel("Monthly Budget",
conditionalPanel("output.any(ReactiveDf() == 'Savings') == TRUE ",
plotOutput("SavingsPlot")
)
########### THIS IS WHERE THE ERROR HAPPENS ##############
),
tabPanel("Budget to Date",
tableOutput("YearTable")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
## SAVE DATA
# Set Up Empty DF
df <- tibble("Name" = character(),
"Date" = character(),
"Category" = character(),
"Amount" = numeric(),
"Description" = character())
# DF is made reactive so we can add new lines
ReactiveDf <- reactiveVal(value = df)
# Add inputs as new data (lines)
observeEvent(input$Submit, {
if (input$Bucket == "" | input$Amount == 0 |
is.na(input$Amount)) {
return(NULL)
}
else {
# New lines are packaged together in a DF
new_lines <- data.frame(Name = as.character(input$Name),
Date = as.character(input$Date),
Category = input$Bucket,
Amount = as.character(input$Amount),
Description = as.character(input$Item))
# change df globally
df <<- rbind(df, new_lines)
# ensure amount is numeric
df <<- df %>%
mutate("Amount" = as.numeric(Amount))
# Update reactive values
ReactiveDf(df)
#clear out original inputs now that they are written to df
updateSelectInput(session, inputId = "Name", selected = "")
updateSelectInput(session, inputId = "Bucket", selected = "")
updateNumericInput(session, inputId = "Amount", value = 0)
updateTextInput(session, inputId = "Item", value = "")
}
})
## Preview Table
observeEvent(input$Submit, {
output$PreviewTable <-
function(){
ReactiveDf()[order(ReactiveDf()$Date, decreasing = TRUE),] %>%
kable("html") %>%
kable_material(c("striped", "hover")) %>%
kable_styling("striped", full_width = TRUE) %>%
column_spec(3, color = "black", background = ifelse(ReactiveDf()[3]=="Essential", "#87CEEB", ifelse(ReactiveDf()[3] == "Non-Essential", "#EBA487", ifelse(ReactiveDf()[3] == "Savings", "#87EBA4", ifelse(ReactiveDf()[3] == "Rent/Bills", "#A487EB", ifelse(ReactiveDf()[3] == "Trip", "#CEEB87", "#EB87CE")))))) %>%
column_spec(1, color = ifelse(ReactiveDf()[1] == "Ashley", "lightpink", "lightcyan"))
}
########## THIS IS THE LINE PLOT I AM TRYING TO RENDER ##########
output$SavingsPlot <- renderPlot({
savings <- ReactiveDf()[ReactiveDf()$Category == "Savings",]
savings <- savings[, -c(1,3,5)]
savings$Date <- as.Date(savings$Date)
savings$Amount <- as.numeric(savings$Amount)
savings <- as.xts(savings$Amount, order.by = as.Date(savings$Date))
weekly <- apply.weekly(savings,sum)
weekly_savings <- as.data.frame(weekly)
weekly_savings$names <- rownames(weekly_savings)
rownames(weekly_savings) <- NULL
colnames(weekly_savings) <- c("Amount", "Date")
Expected <- NULL
for(i in 1:dim(weekly_savings)[1]){
Expected[i] <- i * 625
}
weekly_savings$Expected <- Expected
ggplot(weekly_savings, aes(x = Date)) +
geom_line(aes(y = Expected), color = "red") +
geom_line(aes(y = Amount), color = "blue") +
ggtitle("House Downpayment Savings Over Time") +
ylab("Dollars") +
scale_x_date(date_minor_breaks = "2 day") +
scale_y_continuous(labels=scales::dollar_format())
})
})
########## THIS IS THE LINE PLOT I AM TRYING TO RENDER ##########
# Downloadable csv of selected dataset ----
output$Download <- downloadHandler(
filename = function() {
paste("A&J Budgeting ", Sys.Date(),".csv", sep = "")
},
content = function(file) {
write.csv(ReactiveDf(), file, row.names = FALSE)
}
)
# use if df new lines have errors
observeEvent(input$start_over, {
# change df globally
df <- tibble("Name" = character(),
"Date" = character(),
"Expense Category" = character(),
"Amount" = numeric(),
"Description" = character())
# Update reactive values to empty out df
ReactiveDf(df)
})
## MONTHLY TABLE
output$MonthlyTable <- renderTable({
ReactiveDf()
})
## YEAR TO DATE TABLE
output$YearTable <- renderTable({
ReactiveDf()
})
}
# Run the application
shinyApp(ui = ui, server = server)
We can use a condition like nrow(filter(ReactiveDf(), Category == 'Savings')) > 0 as if ReactiveDf is a normal df. Also, when converting the xts object to a df the Date column was coerced to character.
app:
# Libraries
library(shiny)
library(tidyverse)
library(shinycssloaders)
library(colortools)
library(shinythemes)
library(DT)
library(tidyverse)
library(kableExtra)
library(formattable)
library(xts)
library(lubridate)
# Creating Contrasting Colors For Buckets
bucket_colors <- wheel("skyblue", num = 6)
# Define UI for application that draws a histogram
ui <- fluidPage(
# theme = shinytheme("spacelab"),
shinythemes::themeSelector(),
## Application Title
titlePanel("2021 Budgeting & Finances"),
tags$em("By:"),
tags$hr(),
navbarPage("", id = "Budget",
tabPanel("Data Entry",
div(class = "outer",
# Sidebar Layout
sidebarLayout(
sidebarPanel(
selectInput("Name",
label = "Name:",
choices = c("","Jack", "Jill")),
selectInput("Bucket",
label = "Item Bucket:",
choices = c("","Essential", "Non-Essential", "Savings", "Rent/Bills", "Trip", "Other")),
textInput("Item",
label = "Item Name:",
placeholder = "Ex: McDonald's"),
shinyWidgets::numericInputIcon("Amount",
"Amount:",
value = 0,
step = 0.01,
min = 0,
max = 1000000,
icon = list(icon("dollar"), NULL)),
dateInput("Date",
label = "Date",
value = Sys.Date(),
min = "2021-05-01",
max = "2022-12-31",
format = "M-d-yyyy"),
actionButton("Submit", "Submit", class = "btn btn-primary"),
downloadButton("Download", "Download")),
# Show a plot of the generated distribution
mainPanel(
tableOutput("PreviewTable")
)
)
)
),
tabPanel("Monthly Budget",
plotOutput("SavingsPlot")
),
tabPanel("Budget to Date",
tableOutput("YearTable")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
## SAVE DATA
# Set Up Empty DF
df <- tibble("Name" = character(),
"Date" = character(),
"Category" = character(),
"Amount" = numeric(),
"Description" = character())
# DF is made reactive so we can add new lines
ReactiveDf <- reactiveVal(value = df)
# Add inputs as new data (lines)
observeEvent(input$Submit, {
if (input$Bucket == "" | input$Amount == 0 |
is.na(input$Amount)) {
return(NULL)
}
else {
# New lines are packaged together in a DF
new_lines <- data.frame(Name = as.character(input$Name),
Date = as.character(input$Date),
Category = input$Bucket,
Amount = as.character(input$Amount),
Description = as.character(input$Item))
# change df globally
df <<- rbind(df, new_lines)
# ensure amount is numeric
df <<- df %>%
mutate("Amount" = as.numeric(Amount))
# Update reactive values
ReactiveDf(df)
#clear out original inputs now that they are written to df
updateSelectInput(session, inputId = "Name", selected = "")
updateSelectInput(session, inputId = "Bucket", selected = "")
updateNumericInput(session, inputId = "Amount", value = 0)
updateTextInput(session, inputId = "Item", value = "")
}
})
## Preview Table
observeEvent(input$Submit, {
output$PreviewTable <-
function(){
ReactiveDf()[order(ReactiveDf()$Date, decreasing = TRUE),] %>%
kable("html") %>%
kable_material(c("striped", "hover")) %>%
kable_styling("striped", full_width = TRUE) %>%
column_spec(3, color = "black", background = ifelse(ReactiveDf()[3]=="Essential", "#87CEEB", ifelse(ReactiveDf()[3] == "Non-Essential", "#EBA487", ifelse(ReactiveDf()[3] == "Savings", "#87EBA4", ifelse(ReactiveDf()[3] == "Rent/Bills", "#A487EB", ifelse(ReactiveDf()[3] == "Trip", "#CEEB87", "#EB87CE")))))) %>%
column_spec(1, color = ifelse(ReactiveDf()[1] == "Ashley", "lightpink", "lightcyan"))
}
########## THIS IS THE LINE PLOT I AM TRYING TO RENDER ##########
if (nrow(filter(ReactiveDf(), Category == 'Savings')) > 0) {
output$SavingsPlot <- renderPlot({
savings <- filter(ReactiveDf(), Category == 'Savings')
savings$Date <- as.Date(savings$Date, format = "%Y-%m-%d")
savings$Amount <- as.numeric(savings$Amount)
savings <- as.xts(savings$Amount, order.by = savings$Date)
weekly <- apply.weekly(savings, sum)
weekly_savings <- as.data.frame(weekly)
weekly_savings$names <- rownames(weekly_savings)
rownames(weekly_savings) <- NULL
colnames(weekly_savings) <- c("Amount", "Date")
Expected <- NULL
for(i in 1:dim(weekly_savings)[1]){
Expected[i] <- i * 625
}
weekly_savings$Expected <- Expected
ggplot(weekly_savings, aes(x = ymd(Date))) +
geom_line(aes(y = Expected), color = "red") +
geom_line(aes(y = Amount), color = "blue") +
ggtitle("House Downpayment Savings Over Time") +
ylab("Dollars") +
scale_x_date(date_minor_breaks = "2 day") +
scale_y_continuous(labels=scales::dollar_format())
}) }
})
########## THIS IS THE LINE PLOT I AM TRYING TO RENDER ##########
# Downloadable csv of selected dataset ----
output$Download <- downloadHandler(
filename = function() {
paste("A&J Budgeting ", Sys.Date(),".csv", sep = "")
},
content = function(file) {
write.csv(ReactiveDf(), file, row.names = FALSE)
}
)
# use if df new lines have errors
observeEvent(input$start_over, {
# change df globally
df <- tibble("Name" = character(),
"Date" = character(),
"Expense Category" = character(),
"Amount" = numeric(),
"Description" = character())
# Update reactive values to empty out df
ReactiveDf(df)
})
## MONTHLY TABLE
output$MonthlyTable <- renderTable({
ReactiveDf()
})
## YEAR TO DATE TABLE
output$YearTable <- renderTable({
ReactiveDf()
})
}
# Run the application
shinyApp(ui = ui, server = server)
I created an application in Shiny where I would like to choose multiple items from the drop-down menu. Unfortunately, I don't know how to make items on the list reduce after a given menu selection. By which all lines merge into a whole. what should I add in the code so that each model is a separate line. Below I put a picture with charts.
My code:
library(shiny)
library(plotly)
library(readxl)
library(shinyWidgets)
library(shinydashboard)
library(shinyjs)
library(DT)
df1 <- data.frame(Month = rep(month.abb[1:12],10,replace = TRUE), Model = paste0('Ferrari ', rep(LETTERS[1:10], each = 12)),
Value = sample(c(0:300),120, replace = T),
Car = rep('Ferrari', 10,each = 12), Year = rep(2019:2020, each = 60),Country = rep(c("USA","DE"), each = 12, times = 5), stringsAsFactors = F)
df2 <- data.frame(Month = rep(month.abb[1:12],10,replace = TRUE), Model = paste0('Porsche ', rep(LETTERS[1:10], each = 12)),
Value = sample(c(0:300),120, replace = T),
Car = rep('Porsche', 10,each = 12), Year = rep(2019:2020, each = 60), Country = rep(c("USA","DE"), each = 12, times = 5),stringsAsFactors = F)
data <-rbind(df1, df2)
ui <- fluidPage(
titlePanel("Test"),
sidebarLayout(
sidebarPanel( width = 3,
uiOutput("category1"),
uiOutput("category2"),
uiOutput("category3"),
uiOutput("category4")),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel("Plot", plotlyOutput("plot", height = 550,width = 1000))
)
)
)
)
server <- function(input, output,session) {
output$category1 <- renderUI({
selectInput('cat1', 'Choose year:', multiple = T, selected = NULL, choices = sort(as.numeric(unique(data$Year))))
})
df_subset <- eventReactive(input$cat1,{
if(input$cat1=="All") {df_subset <- data}
else{df_subset <- data[data$Year == input$cat1,]}
})
df_subset1 <- reactive({
if(is.null(input$cat2)){df_subset()} else {df_subset()[df_subset()$Country %in% input$cat2,]}
})
output$category2 <- renderUI({
selectInput('cat2', 'Choose country:', choices = sort(as.character(unique(df_subset()$Country))), multiple = T, selected = NULL)
})
df_subset2 <- reactive({
if(is.null(input$cat3)){df_subset1()} else {df_subset1()[df_subset1()$Car %in% input$cat3,]}
})
output$category3 <- renderUI({
selectInput('cat3', 'Choose car:', choices = sort(as.character(unique(df_subset1()$Car))), multiple = F, selected = NULL)
})
df_subset3 <- reactive({
if(is.null(input$cat4)){df_subset2()} else {df_subset2()[df_subset2()$Model %in% input$cat4,]}
})
output$category4 <- renderUI({
pickerInput('cat4', 'Choose model:', choices = sort(as.character(unique(df_subset2()$Model))), multiple = TRUE, selected = NULL)
})
output$plot <- renderPlotly({
xform <- list(categoryorder = "array",
categoryarray = df_subset3()$Month,
title = " ",
nticks=12)
plot_ly(data=df_subset3(), x=~Month, y = ~Value, type = 'scatter', mode = 'lines', name = 'Value') %>%
layout(title = " ",xaxis = xform) %>%
layout(legend = list(orientation = 'h', xanchor = "center", y=1.1, x=0.5))
})
}
shinyApp(ui, server)
To display each model as a separate line on the plot, you can assign the Model column of your dataset to the color parameter of plot_ly this way:
plot_ly( data = df_subset3(), x = ~Month, y = ~Value, color = ~Model, ...)
Error while geocoding addresses in my shiny app
I wish to upload a file in my shiny app and and then calculate latitude and longitude.Below is the code and here is the LINK(https://github.com/Pujaguptagithub/My_Data) to the dataset used.Please help as I am new to shiny.
library(shiny)
library(dplyr)
library(readxl)
library(sf)
library(mapsapi)
library(gsubfn)
library(pipeR)
ui <- fluidPage(
fileInput('csvFile', 'Choose xlsx file',
accept = c(".xlsx")),
tableOutput("rawData"),
tableOutput("modifiedData")
)
server <- function(input, output, session) {
rawData <- eventReactive(input$csvFile, {
read_excel(input$csvFile$datapath)
})
output$rawData <- renderTable({
rawData() %>% head
})
output$modifiedData <- renderTable({
rawData() %>% mutate(Locations = paste(as.character(rawData()$Address),
as.character(rawData()$City),as.character(rawData()$State),
as.character(rawData()$`Zip Code`), as.character(rawData()$Country),
sep=",")) %>%
mutate(aaa = gsub("NA;", "", Locations)) %>%
mutate(bbbb = mp_geocode(addresses = aaa, region = NULL, bounds = NULL,
key = "AIzaSyBQDna1fNBT5qeET39A0lp9nNEdezRLVyI")) %>%
mutate(ccc = mp_get_points(bbbb)) %>%
mutate(pnt = sub(ccc$pnt, pattern = "c", replacement = "")) %>%
mutate(eee = sub(pnt, pattern = "[(]", replacement = "")) %>%
mutate(ffff = sub(eee, pattern = "[)]", replacement = "")) %>%
mutate(gggg = sub(ffff, pattern = ",", replacement = "")) %>%
mutate(hhh = unlist(strsplit(gggg, split = " "))) %>%
mutate(Latitude = as.numeric(hhh[seq(2, length(hhh), 2)])) %>%
mutate(Longitude = as.numeric(hhh[seq(1, length(hhh), 2)]))
})
}
shinyApp(ui, server)
The below code works perfect outside the shiny :
Locations <- paste(Latlong$Address, Latlong$City,Latlong$State,Latlong$`Zip
Code`, Latlong$Country, sep=",")
Locations <- gsub("NA;", "", Locations)
Locations <- mp_geocode(addresses = Locations, region = NULL, bounds =
NULL, key = "AIzaSyBQDna1fNBT5qeET39A0lp9nNEdezRLVyI")
Locations = mp_get_points(Locations)
geom <- sub(Locations$pnt, pattern = "c", replacement = "")
geom <- sub(geom, pattern = "[(]", replacement = "")
geom <- sub(geom, pattern = "[)]", replacement = "")
geom <- sub(geom, pattern = ",", replacement = "")
lonlat <- unlist(strsplit(geom, split = " "))
Latlong$Latitude <- as.numeric(lonlat[seq(2, length(lonlat), 2)])
Latlong$Longitude <- as.numeric(lonlat[seq(1, length(lonlat), 2)])
check my entire app below, the only problem is due to line "df_svb <- Latlong", please help to get rid off the error.
library(shinyjs)
library(shinyWidgets)
library(shiny)
library(shinydashboard)
library(tidyverse)
library(devtools)
library(rsconnect)
library(readxl)
library(DT)
library(writexl)
library(stringi)
library(shinydashboardPlus)
library(ggmap)
library(zipcode)
library(leaflet)
library(htmltools)
library(data.table)
library(plotly)
library(mapsapi)
library(readxl)
Template <- read_excel("C:/Users/Template.xlsx")
header <- dashboardHeader(
# Set height of dashboardHeader
tags$li(class = "dropdown",
tags$style(".main-header .logo {height: 0px;}")),
title = div(img(src = 'svb_small.png',
style = "position:absolute; left:15px;
height: 80px;"))
)
##### Sidebar
sidebar <- dashboardSidebar(
shinyjs::useShinyjs(),
width = 400,
menuItem('Inputs',
id = 'side_panel',
#icon = icon("bar-chart-o"),
startExpanded = TRUE,
br(), br(),
fileInput('csvFile', 'Choose xlsx file',
accept = c(".xlsx")),
div(style = "font-size: 150%; font-family: sans-serif;",
selectizeGroupUI(
id = "my_filters",
params = list(
Country = list(inputId = "Country", title = "Country:"),
Company = list(inputId = "Company", title = "Company:")),
inline = FALSE)),
br(),
br(),
br(),
br(),
br(),
br(),
br(),
br(),
br(),
br(),
br(),
br(),
br(),
br(),
br(),
br(),
downloadBttn('downloadData',
label = 'Download Template',
style = "gradient",
color = "primary"
)
)
)
body <- dashboardBody(
tags$style(type = "text/css", "#map_1 {height: calc(100vh - 80px)
!important;}"),
addSpinner(
leafletOutput("map_1"),
spin = 'folding-cube')
)
# Put them together into a dashboardPage
ui <- dashboardPage(header,sidebar,body, skin = "black")
options(shiny.maxRequestSize = 15*1024^2)
server <- function(input, output, session) {
rawData <- eventReactive(input$csvFile, {
read_excel(input$csvFile$datapath)
})
# Download template
output$downloadData <- downloadHandler(
filename = function() {"CBRE Geocoding and mapping Application.xlsx"},
content = function(file) {write_xlsx(Template, path = file)}
)
#SelectizeGroup function creates mutually dependent input filters
res_mod <- callModule(
module = selectizeGroupServer,
id = "my_filters",
data = df_svb,
vars = c('Country', 'Company')
)
modifiedData <- renderTable({
Latlong <- rawData()
Locations <- paste(Latlong$Address,
Latlong$City,Latlong$State,Latlong$`Zip Code`,
Latlong$Country, sep=",")
Locations <- gsub("NA;", "", Locations)
Locations <- mp_geocode(addresses = Locations, region = NULL, bounds=
NULL, key =
"AIzaSyBQDna1fNBT5qeET39A0lp9nNEdezRLVyI")
Locations = mp_get_points(Locations)
geom <- sub(Locations$pnt, pattern = "c", replacement = "")
geom <- sub(geom, pattern = "[(]", replacement = "")
geom <- sub(geom, pattern = "[)]", replacement = "")
geom <- sub(geom, pattern = ",", replacement = "")
lonlat <- unlist(strsplit(geom, split = " "))
Latlong$Latitude <- as.numeric(lonlat[seq(2, length(lonlat), 2)])
Latlong$Longitude <- as.numeric(lonlat[seq(1, length(lonlat), 2)])
Latlong
})
############################################################
df_svb <- Latlong
df_svb <- Latlong%>% mutate(
X = paste0('<font color="#006A4D">',
'<font-family: sans-serif>',
'<font size = "5">',
'<strong><font color="black">Country: </font color="black">
</strong>',
Country,
'<br><strong><font color="black">Company: </font color="black">
</strong>',
Company))
qpal <- colorFactor("BuPu", as.factor(df_svb$Company))
output$map_1 <- renderLeaflet(
leaflet(data = res_mod()) %>%
setView(-94.578568, 39.099728, zoom = 5) %>%
addProviderTiles(providers$Esri.WorldImagery, group = "Imagery Map") %>%
addProviderTiles(providers$Esri.WorldStreetMap, group = 'Street Map') %>%
addCircleMarkers(~Longitude, ~Latitude, group = 'svb',
fillColor = ~qpal(res_mod()$Company),
color = c("#006A4D","#FF0000"),
stroke = FALSE,
fillOpacity = 15,radius = 15,
labelOptions = labelOptions(noHide = T)
) %>%
addLayersControl(baseGroups = c('Street Map', "Imagery Map"),
options = layersControlOptions(collapsed = TRUE)) %>%
hideGroup('CBRE Locations') %>%
addLegend("topright", pal = qpal, values = ~res_mod()$Company,
title = "Company:", opacity = 1,group = 'svb' )
)
#Zooms in map when 1 office is chosen.
observe({
req(n_distinct(res_mod()$Country) == 1)
proxy <- leafletProxy('map_1')
proxy %>% setView(head(res_mod()$Longitude,1),
head(res_mod()$Latitude,1), zoom = 12)
})
}
shinyApp(ui, server)
UPDATE:
To add the data as a map, add this to the UI definition:
leafletOutput(outputId="myMap", height = 480)
And this will guide you on creating the server function:
output$myMap <- renderLeaflet({
# Test Data
#name <- c("London","Paris","Dublin")
#latitude <- c(51.5074,48.8566, 53.3498)
#longitude <- c(0.1278,2.3522, -6.2603)
#Latlong <- data.frame(name, latitude, longitude)
# Convert data frame to shape
coordinates(Latlong)<-~longitude+latitude
proj4string(Latlong)<- CRS("+proj=longlat +datum=WGS84")
shapeData <- spTransform(data,CRS("+proj=longlat"))
# Map the shape
map <- tm_shape(shapeData, name="Cities") +
tm_dots(size=0.2,title="Cities") +
tm_basemap("OpenStreetMap")+
tm_basemap("Esri.WorldImagery")
tmap_leaflet(map)
})
Original:
The issue seems to be in your call to the geocode function mp_get_points(). This is returning an xml document that can't be inserted into the new dataframe column ccc.
Is there any reason why you abandoned your original code? This seems to work fine if I insert it into your shiny app.
output$modifiedData <- renderTable({
Latlong <- rawData()
Locations <- paste(Latlong$Address, Latlong$City,Latlong$State,Latlong$`Zip
Code`, Latlong$Country, sep=",")
Locations <- gsub("NA;", "", Locations)
Locations <- mp_geocode(addresses = Locations, region = NULL, bounds =
NULL, key = "AIzaSyBQDna1fNBT5qeET39A0lp9nNEdezRLVyI")
Locations = mp_get_points(Locations)
geom <- sub(Locations$pnt, pattern = "c", replacement = "")
geom <- sub(geom, pattern = "[(]", replacement = "")
geom <- sub(geom, pattern = "[)]", replacement = "")
geom <- sub(geom, pattern = ",", replacement = "")
lonlat <- unlist(strsplit(geom, split = " "))
Latlong$Latitude <- as.numeric(lonlat[seq(2, length(lonlat), 2)])
Latlong$Longitude <- as.numeric(lonlat[seq(1, length(lonlat), 2)])
Latlong
})
I have been messing with making a shiny app and I feel as though i am doing everything in the correct manner to get the table to render but no luck. In my app you should you upload an csv and then go to the data frame tab. I have tried many small changes but nothing seems to work. Id imagine this has something to do with the server section but i cant see it.
R ui:
library(readxl)
library(plyr)
library(dplyr)
library(plotly)
library(readr)
library(RColorBrewer)
library(data.table)
library(shiny)
library(shinydashboard)
library(shinythemes)
library(leaflet)
library(DT)
library(xtable)
ui <- fluidPage(theme = shinytheme("slate"), mainPanel(
navbarPage(
"Permian Plots", collapsible = TRUE, fluid = TRUE,
navbarMenu(
"County Plot",
tabPanel(
sidebarPanel( fileInput(
'file1',
'Choose CSV File',
accept = c('text/csv', 'text/comma-separated-values,text/plain', '.csv')
),
tags$hr(),
checkboxInput('header', 'Header', TRUE),
# App buttons comma and quote
radioButtons('sep', 'Separator',
c(
Comma = ',',
Semicolon = ';',
Tab = '\t'
), ','),
radioButtons(
'quote',
'Quote',
c(
None = '',
'Double Quote' = '"',
'Single Quote' = "'"
),
'"'
))
),
tabPanel("Data Frame",
fluidRow(box(DT::dataTableOutput("contents")))),
tabPanel("County Plot", plotlyOutput(
"plotMap", height = 1200, width = 1200
),
actionButton("btn", "Plot")
)
)
)
)
)
Server:
server <- function(input, output, session) {
options(shiny.maxRequestSize = 200*1024^2)
dsnames <- c()
data_set <- reactive({
inFile <- input$file1
if (is.null(inFile)){
return()
}
data_set <- read.csv(
inFile$datapath,
header = input$header,
sep = input$sep,
quote = input$quote
)
})
output$contents <- DT::renderDataTable({
withProgress(message = 'loading...', value = 0.1, {
datatable(data_set(),
options = list(
"pageLength" = 40))
extensions = 'Responsive'
setProgress(1)
})
})
output$choose_dataset <- renderUI({
selectInput("dataset", "Data set", as.list(data_sets))
})
observeEvent(
input$btn,
{
output$plotMap <- renderPlotly({withProgress(message = 'Plotting...', value = 0.1,{
plot <- Plots(data_set(),
"Martin County",
"~/Work/permin/martin county/martin data/f1.csv",
"~/Work/permin/BestMartinPlotSat.html",
32.1511, -101.5715)
setProgress(1)
})
})
}
)
}
shinyApp(ui = ui, server = server)
Function:
Should not be the problem causer in this.
Plots <- function(df, C_name, PathCSV, PathWidg, Lat, Lon){
f1 <- df
f1$Date <- as.POSIXct(f1$Date)
f1$year <- format(as.POSIXct(f1$Date,format="%y-%m-%d"), "%y")
f1$month <- format(as.POSIXct(f1$Date,format="%y-%m-%d"), "%m")
f1$Cell <- as.factor(f1$Cell)
z <- ddply(f1, c("year", "month", "Cell"), summarise,
yearMonth_Max_sum = max(`Cell Sum (Norm)`))
f1 <- inner_join(f1,z, by = c("year", "month", "Cell"))
f1$Changed <- as.numeric(as.factor(f1$Changed))
f1$Changed[f1$Changed == 1] <- 0
f1$Changed[f1$Changed == 2] <- 1
z <- ddply(f1, c("year", "month", "Cell"), summarise,
ChangedX = max(Changed))
f1 <- inner_join(f1,z, by = c("year", "month", "Cell"))
f1$MY <- paste(f1$year, f1$month, sep = "-")
#preapring data for plotly
q <- matrix(quantile(f1$StdDev))
f1$qunat <- NA
up <- matrix(quantile(f1$StdDev, probs = .95))
up
f1$qunat <- ifelse((f1$StdDev > q[4:4,1]) & (f1$StdDev < up[1,1]), 1, 0)
z <- group_by(f1, Cell) %>%
summarize(Median_Cell = median(`Cell Sum (Norm)`, na.rm = FALSE))
f1 <- inner_join(f1,z, by = c("Cell"))
quantile(round(f1$Median_Cell))
f1$NewMedian <- NA
f1$NewMedian[f1$Median_Cell > 4000] <- 0
f1$NewMedian[f1$Median_Cell <= 4000] <- 1
f1$NewSum <- NA
f1$NewSum <- f1$yearMonth_Max_sum * f1$ChangedX * f1$qunat * f1$NewMedian
write_csv(f1, PathCSV )
f2 <- f1[!duplicated(f1$yearMonth_Max_sum), ]
#plolty plot
Sys.setenv('MAPBOX_TOKEN' = 'pk.eyJ1IjoiY3dvb2RzMjIiLCJhIjoiY2prMnlycmduMDJvNjNxdDEzczNjdGt3YSJ9.RNuCSlHyKZpkTQ8mJmg4aw')
p <- f2[which(f2$yearMonth_Max_sum < 9000),] %>%
plot_mapbox(
lon = ~Lon,
lat = ~Lat,
size = ~yearMonth_Max_sum,
color = ~(NewSum),
frame = ~MY,
type = 'scattermapbox',
mode = 'markers',
colors = c("green","blue")
) %>%
add_markers(text = ~paste("Sum", yearMonth_Max_sum, "/<br>",
"Standard Dev", StdDev, "/<br>",
"Mean", Average, "/<br>",
"Median", Median_Cell, "/<br>",
"Changed", ChangedX, "/<br>",
"Latitude", Lat , "/<br>",
"Longitude", Lon)) %>%
layout(title = C_name,
font = list(color = "black"),
mapbox = list(style = "satellite", zoom = 9,
center = list(lat = Lat,
lon = Lon)))
p
htmlwidgets::saveWidget(p, PathWidg)
}
the last thing in your function is what is returned. you are returning setprogress(1) to renderdatatable()
output$contents <- DT::renderDataTable({
withProgress(message = 'loading...', value = 0.1, {
datatable(data_set(),
options = list(
"pageLength" = 40))
extensions = 'Responsive'
setProgress(1)
})
Try this instead
output$contents <- DT::renderDataTable({
withProgress(message = 'loading...', value = 0.1, {
datatab <- datatable(data_set(),
options = list(
"pageLength" = 40))
extensions = 'Responsive'
setProgress(1)
datatab
})