checkboxInput R shiny. Insert a condition - r

I have the following code and I have created two checkbox inputs.
So, I created a pos variable that takes one of the two strings for the first input. This works.
Now, I want to create a new variable pll that fills the graph according to one of the two variables (type and employee) of my data set. I use the following code but this does not work. Do you have any idea
library(shiny)
library(shinyWidgets)
library(tidyverse)
library(DT)
library(shinythemes)
library(plotly)
library(ggthemes)
library(lubridate)
data <- data.frame(mitarbeiter = c("AA", "BB", "CC", "DD", "EE", "FF"),
art = c("hr", "GG", "TT", "RR", "OO", "OO"),
creadate = as_date(c("2018-01-03", "2018-01-03", "2018-01-03", "2018-01-03", "2018-01-03", "2018-01-03")))
mitarbeiter1 <- sort(unique(data$mitarbeiter))
art1 <- sort(unique(data$art))
year_month <- function(dates) {
paste(lubridate::year(dates),
str_pad(lubridate::month(dates), width = 2, pad = 0),
sep="-")
}
year_week <- function(dates) {
paste(lubridate::year(dates),
str_pad(lubridate::week(dates), width = 2, pad = 0),
sep="-")
}
year_day <- function(dates) {
paste(lubridate::year(dates),
str_pad(lubridate::month(dates), width = 2, pad = 0),
str_pad(lubridate::day(dates), width = 2, pad = 0),
sep="-")
}
ui <- fluidPage(
fluidRow(
column(4,
pickerInput("mitarbeiterName", "Name des Mitarbeiters", mitarbeiter1,
options = list(`actions-box` = TRUE), multiple = TRUE),
pickerInput("artName", "Art", art1,
options = list(`actions-box` = TRUE), multiple = TRUE),
pickerInput("period", "Zeitraum", c("day", "week", "month", "year"),
options = list(`actions-box` = TRUE)),
dateRangeInput("date", "Datum auswahlen", start = "2020-01-01"),
checkboxInput("kumulativ", "Kumulativ"),
checkboxInput("tf", "TF"),
downloadButton("download", "Download")
),
column(8,
plotlyOutput("policyPlot")
)
)
)
server <- function(input, output, session) {
#create a reactive object with a NULL starting value
listofrows <- reactiveValues(data = NULL)
#observe the changes in inputs and update the reactive object
observeEvent(c(input$mitarbeiterName, input$artName, input$date, input$period), {
req(input$mitarbeiterName)
req(input$artName)
req(input$period)
req(input$date)
listofrows$data <- subset(data, mitarbeiter %in% input$mitarbeiterName &
art %in% input$artName &
creadate >= input$date[1] & creadate <= input$date[2])
}, ignoreInit = T, ignoreNULL = TRUE)
output$policyPlot <- renderPlotly({
req(listofrows$data)
req(input$kumulativ)
fn <- switch(
input$period,
day = year_day,
week = year_week,
month = year_month,
year = year
)
pos <- if (input$kumulativ) "dodge" else "identity"
pll <- if (input$tf) type else employee
ggplot(listofrows$data) +
geom_bar(aes(x = fn(creadate), fill = pll),
stat = "count",
position = pos,
show.legend = T) +
ggtitle("Anzahl erstellte Policen (pro Mitarbeiter)") +
xlab("Zeitraum") + ylab("Anzahl der Policen")
})
output$download <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".png", sep = "")
},
content = function(file) {
ggsave(file, plot = output$policyPlot)
})
}
shinyApp(ui, server)
Do you have any idea how to make this work? thanks

Errors I noticed :
No declaration of reactive session_store
missing call to library plotly
aes instead of aes_string when using ggplot with variable name stored in variable, because here pll is a string of a variable name
Please remember to provide a reproductible example when asking a question, with a minimum usable dataset.
library(shiny)
library(shinyWidgets)
library(tidyverse)
library(DT)
library(shinythemes)
library(plotly)
data <- data.frame(employee = c("A", "B", "C", "A", "B", "C"),
type = c('1','2','3', '4', '2', '1'),
date = c("2020-01-01", "2020-01-02", "2020-01-01", "2020-01-02", "2020-01-02", "2020-01-02"))
ui <- fluidPage(
fluidRow(
column(4,
checkboxInput("cumulative", "Cumulative"),
checkboxInput("tf", "TF")
),
column(8,
plotlyOutput("policyPlot")
)
)
)
server <- function(input, output, session) {
session_store <- reactiveValues()
output$policyPlot <- renderPlotly({
pos <- if (input$cumulative) "stack" else "dodge"
pll <- if (input$tf) 'type' else 'employee'
# make a ggplot graph
g <- ggplot(data) +
geom_bar(aes_string('date', fill = pll),
stat = "count",
position = pos,
show.legend = T)
# convert the graph to plotly graph and put it in session store
session_store$plt <- ggplotly(g)
# render plotly graph
session_store$plt
})
}
shinyApp(ui, server)

Related

Display line plot when condition is met in data entry

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)

Using R Shiny User Input with RSQLite

I want to create a shiny app that takes the first date range as inputs for the SQL command to query from the RSQLite db I created. However, when I run this without having a df object prior to running the app, it does not work. If I try to update the long lat slider ranges that are currently commented out, this crashes the app. I also keep getting this error: Warning in if (!loaded) { :
the condition has length > 1 and only the first element will be used
c("Loading required package: [", "Loading required package: input$timestamp", "Loading required package: 1")
Failed with error: ‘'package' must be of length 1’
Can anyone help? I just want the user to give me the first date and last date ranges to query the database and then have dplyr do the rest of the filtering.
library(dplyr)
library(htmltools)
library(leaflet)
library(leafem)
library(shiny)
library(shinyjs)
library(shinyWidgets)
library(shinythemes)
library(shinyBS)
#Create a formatted timestamp for filename
humanTime <- function() format(Sys.time(), "%Y-%m-%d_%H-%M-%OS")
#Create a Dummy Dataset
get_data <- function(size){
df <- data.frame(OBJECT_ID = seq(from =1, to = size, by = 1))
df$LONGITUDE <- sample(seq(from=-20, to =160, by = 0.01), size, rep= TRUE)
df$LATITUDE <- sample(seq(from = -10, to= 83, by = 0.01), size, rep= TRUE)
df$LOCATION <- sample(c("A", "B", "C"), size, replace = T, prob = c(0.4, 0.4, 0.2))
df$EQUIPMENT <- sample(c("E1", "E2", "E3", "E4"), size, replace = TRUE)
startTime <- as.POSIXct("2016-01-01")
endTime <- as.POSIXct("2019-01-31")
df$DATE <- as.character(as.Date(sample(seq(startTime, endTime, 1), size))) #use as.Date to remove times
df$WEEKDAY <- weekdays(as.Date(df$DATE))
return(df)
}
#Is this necessary to get the ranges for the slider values?
df <- get_data(200)
df$DATE <- as.Date(df$DATE)
df <- df %>% mutate_if(is.character, as.factor)
ui <- navbarPage(
id = "navBar",
title = "Data Exploration",
theme = shinytheme("cerulean"),
shinyjs::useShinyjs(),
selected = "Data",
tabPanel("Data",
fluidPage(
sidebarPanel(
div(id = "form",
dateRangeInput('timestamp', label = 'Date range input:', start = '', end = ''),
pickerInput('days_of_week', 'Choose Weekdays:', choices = c("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday"), options = list(`actions-box` = TRUE), multiple = T),
sliderInput('long', "Longitude Range:", min = min(df$LONGITUDE),max = max(df$LONGITUDE), value = c(min(df$LONGITUDE), max(df$LONGITUDE)), step = 0.1),
sliderInput('lat', "Latitude Range:", min = min(df$LATITUDE),max = max(df$LATITUDE), value = c(min(df$LATITUDE), max(df$LATITUDE)), step = 0.1),
pickerInput('location', "Select Location:", choices = unique(df$LOCATION), options = list(`actions-box` = TRUE), multiple = T),
pickerInput('equipment_type', "Choose Equipment:", choices = unique(df$EQUIPMENT), options = list(`actions-box` = TRUE), multiple = T),
actionButton("resetAll", "Reset Filters"),
selectInput("download_type", "Choose download formatt:", choices = c("CSV" = ".csv", "KML" = ".KML")))
),
mainPanel(
leafletOutput("datamap", width = "100%", height = 400),
DT::DTOutput('datatable')))
)
)#end the ui
server <- function(session, input, output){
filter_by_dates <- reactive({
require(input$timestamp[1])
require(input$timestamp[2])
my_conn <- dbConnect(RSQLite::SQLite(), "sample.db")
df <- DBI::dbGetQuery(my_conn, paste0("SELECT * FROM Table_1 WHERE DATE >= '", input$timestamp[1], "' AND DATE <= '", input$timestamp[2], "'"))
df$DATE <- as.Date(df$DATE)
df <- df %>% mutate_if(is.character, as.factor)
DBI::dbDisconnect(my_conn)
return(df)
})
filter_by_all <- reactive({
fd <- filter_by_dates()
if (!is.null(input$days_of_week)) {
fd <- filter(fd, WEEKDAY %in% input$days_of_week)
}
if (!is.null(input$long[1] & input$long[2])){
fd <- filter(fd, LONGITUDE >= input$long[1] & LONGITUDE <= input$long[2])
}
if (!is.null(input$lat[1] & input$lat[2])){
fd <- filter(fd, LATITUDE >= input$lat[1] & LATITUDE <= input$lat[2])
}
if (!is.null(input$location)) {
fd <- filter(fd, LOCATION %in% input$location)
}
if (!is.null(input$equipment_type)) {
fd <- filter(fd, EQUIPMENT %in% input$equipment_type)
}
return(fd)
})
observe({
require(input$timestamp[1])
require(input$timestamp[2])
updatePickerInput(session, 'days_of_week', 'Choose Weekdays:', choices = sort(unique(filter_by_all()$WEEKDAY), decreasing = T), selected = sort(input$days_of_week, decreasing = T))
#updateSliderInput(session, 'long', "Longitude Range:", min=min(filter_by_all()$LONGITUDE), max = max(filter_by_all()$LONGITUDE), value = c(input$long[1], input$long[2]))
#updateSliderInput(session, 'lat', "Latitude Range:", min=min(filter_by_all()$LATITUDE), max = max(filter_by_all()$LATITUDE), value = c(input$lat[1], input$lat[2]))
updatePickerInput(session, 'location', "Select Location:", choices = unique(filter_by_all()$LOCATION), selected = input$location)
updatePickerInput(session, 'equipment_type', "Choose Equipment:", choices = unique(filter_by_all()$EQUIPMENT), selected = input$equipment_type)
})
#Map is updated by User inputs
output$datamap <- renderLeaflet({
leaflet(data = filter_by_all() ) %>%
addCircleMarkers(
lng = ~LONGITUDE,
lat = ~LATITUDE,
radius = 3) %>%
addTiles(group = "ESRI") %>%
addTiles(group = "OSM") %>%
addProviderTiles("Esri.WorldImagery", group = "ESRI") %>%
addProviderTiles("Stamen.Toner", group = "Stamen") %>%
addLayersControl(baseGroup = c("ESRI", "OSM", "Stamen"))
})
output$datatable <- DT::renderDT({
filter_by_all()
}, server = FALSE) #this was used with SharedData doesn't work with downloading data so scrap
#Allow the user to reset all their inputs
observeEvent(input$resetAll, {
reset("form")
})
}#end server
shinyApp(ui, server)

Creating variables when importing data into the shiny-application, managing the received data

Comrades! Greetings.
Please help me out ... there is some significant misunderstanding.
Suppose I created like this data.frame:
df<-data.frame(num = c(1:250),
app_num = sample(1:100, 250, replace=T),
entrance=sample(1:4, 250, replace=T),
gender=sample(c('m','f'), 250,replace=T),
age= sample(1:100, 250, replace=T))
I save it in the "*csv" format, using the command:
write.csv2(data_file,file = file.choose(new = T), row.names = FALSE, quote = FALSE)
O.K.
Now I want to create a shiny-application for displaying and working with this data like his:
library("shiny")
#to work with extra string functions
library("stringr")
library("data.table")
library("readr")
# Define UI for application that draws a histogram
ui <- fluidPage(
titlePanel(h2(strong("Analysis of the composition and structure of residents"),
align = "center")),
fileInput(
inputId="fileInput",
label="Choose file",
multiple = FALSE,
accept = ".csv",
width = '100%',
buttonLabel = "Choosing ...",
placeholder = "No files selected yet"
),
sidebarPanel(
checkboxGroupInput(inputId="gender", label = "Choosing a gender feature:",
choices = c("Men" = "m",
"Women" = "f"),
selected= c("Men" = "m",
"Women" = "f")),
sliderInput(inputId = "age", label = "Indicate the age group:",
min = 1, max = 100, value = c(1, 100)),
selectInput(
inputId = "group",
label="Indicate the entrance",
choices=c(1:4),
selected = c(1:4),
multiple = TRUE,
selectize = TRUE,
width = NULL,
size = NULL
)
),
mainPanel(
navbarPage("",
tabPanel("Сommon data",
textOutput(outputId = "text1"),
),
tabPanel("Results table",
dataTableOutput(outputId = "content")
),
tabPanel("Graphic data")
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
fileinfor <- reactiveValues(file=NULL,
ext=NULL,
datapath=NULL)
output$content <- renderDataTable({
fileinfor$file <- input$fileInput
fileinfor$datapath<-fileinfor$file$datapath
fileinfor.datapath <- fileinfor$file$datapath
fileinfor$ext <- tools::file_ext(fileinfor$datapath)
req(fileinfor$file)
validate(need(fileinfor$ext== "csv", "Please upload a csv file"))
fread(fileinfor$datapath,
showProgress = FALSE,
sep=";", quote="",header=TRUE)
})
output$text1 <- renderUI(renderText({
paste("Check ", fileinfor$datapath)
}))
}
# Run the application
shinyApp(ui = ui, server = server)
On the server side, I have several questions:
How to get the data correctly so that you can create a variable based on it and use it several times. On the example of my code, you can see that the server-side code block below no longer sees the created variable:
output $ text1 <- renderUI (renderText ({
paste ("Check", fileinfor $ datapath)
}))
Could you show by my example the creation of manipulated variables and their application? Can't figure out where and how to move?
Perhaps you are looking for this.
server <- function(input, output) {
mydf <- reactive({
req(input$fileInput)
inData <- input$fileInput
if (is.null(inData)){ return(NULL) }
mydata <- read.csv(inData$datapath, header = TRUE, sep=",")
})
output$content <- renderDT(mydf())
output$text1 <- renderText({
req(input$fileInput)
paste("Check ", input$fileInput$datapath)
})
}
First of all, I would like to thank #YBS for this teaching.
Thanks to these tips, I managed to solve half of the problem.
The essence of the solution lies in how Shainiy works with variables. In fact, there is no way to store variables like when writing regular code. However, you can write a reactive function that will receive data and issue it to a variable that is within the framework of another function when called.
It should be noted that an explicit mention of this approach was found in the tutorial "Mastering Shiny"
As a result, a version of the working code was obtained.
If you want to try the end result, then sequentially sell the following steps:
Create a CSV file for our experiment:
df<-data.frame(num = c(1:250),
app_num = sample(1:100, 250, replace=T),
entrance=sample(1:4, 250, replace=T),
gender=sample(c('m','f'), 250,replace=T),
age= sample(1:100, 250, replace=T))
Save it in the "*csv" format, using the command:
write.csv2(data_file,file = file.choose(new = T), row.names = FALSE, quote = FALSE)
Use the below mentioned code to create Shiny app:
library("shiny")
library("stringr")
library("data.table")
library("readr")
library("DT")
library("readr")
library("here")
library("ggplot2")
library("dplyr")
library("tidyr")
# Define UI for application that draws a histogram
ui <- fluidPage(
titlePanel(h2(strong("Analysis of the composition and structure of residents"),
align = "center")),
fileInput(
inputId="fileInput",
label="Choose file",
multiple = FALSE,
accept = ".csv",
width = '100%',
buttonLabel = "Choosing ...",
placeholder = "No files selected yet"
),
sidebarPanel(
checkboxGroupInput(inputId="gender", label = "Choosing a gender feature:",
choices = c("Men" = "M",
"Women" = "F"),
selected= c("Men" = "M",
"Women" = "F")),
sliderInput(inputId = "age", label = "Indicate the age group:",
min = 1, max = 100, value = c(1, 100)),
selectInput(
inputId = "group",
label="Indicate the entrance",
choices=c(1:4),
selected = c(1:4),
multiple = TRUE,
selectize = TRUE,
width = NULL,
size = NULL
)
),
mainPanel(
navbarPage("",
tabPanel("РЎommon data",
textOutput(outputId = "text1")
),
tabPanel("Results table",
dataTableOutput(outputId = "content")
),
tabPanel("Graphic data",
plotOutput(outputId = "my_plot")
)
)
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
fileinfor <- reactiveValues(file=NULL,
ext=NULL,
datapath=NULL)
gender = reactive({
gender <- input$gender
gender
})
age = reactive({
cbind(input$age[1],input$age[2])
})
group = reactive({
input$group
})
import_data <- reactive({
req(input$fileInput)
fileinfor$file <- input$fileInput
if (is.null(input$fileInput)){ return(NULL) }
fileinfor$datapath<-fileinfor$file$datapath
fileinfor$ext <- tools::file_ext(fileinfor$datapath)
validate(need(fileinfor$ext== "csv", "Please upload a csv file"))
import_data <- fread(fileinfor$datapath,
showProgress = FALSE,
sep=";", quote="",header=TRUE)
})
output$content <- renderDT({
GENDER = gender()
GROUP = group()
AGE = age()
req(import_data())
data_file <- import_data()
names(data_file) <- c("ID", "App", "Entrance", "Gender", "Age")
data_file <- mutate_at(data_file, vars(Gender), as.factor)
data_file<- mutate(data_file, Gender = factor(Gender, labels = c("F", "M")))
data_file <- subset(data_file,data_file$Age>=AGE[1]
& data_file$Age<=AGE[2]
& data_file$Entrance %in% GROUP
& data_file$Gender %in% GENDER)
})
output$text1 <- renderText({
req(input$fileInput)
gender <- gender()
paste(length(gender))
})
output$my_plot= reactivePlot(function(){
GENDER = gender()
GROUP = group()
AGE = age()
req(import_data())
data_file <- import_data()
names(data_file) <- c("ID", "App", "Entrance", "Gender", "Age")
data_file <- mutate_at(data_file, vars(Gender), as.factor)
data_file<- mutate(data_file, Gender = factor(Gender, labels = c("F", "M")))
data_file <- subset(data_file,data_file$Age>=AGE[1]
& data_file$Age<=AGE[2]
& data_file$Entrance %in% GROUP
& data_file$Gender %in% GENDER)
df <- group_by(data_file, data_file$Entrance, data_file$Gender)
df <- summarise(df, N = n())
names(df) <- c("Entrance", "Gender", "Quantity")
df <- mutate_at(df, vars(Gender), as.factor)
print(data_file$Gender)
#df <- mutate(df, Gender = factor(Gender, levels = c("f", "m")))
df <- complete(df, Gender, fill = list(M = 0, F = 0))
baseR.sbst.rssgn <- function(x) {
x[is.na(x)] <- 0
x
}
df$Quantity <- baseR.sbst.rssgn(df$Quantity)
ggplot(data = df, aes(x = factor(df$Gender), y = df$Quantity, fill = df$Gender)) +
geom_bar(stat = "identity", position = position_dodge2(0.9)) +
geom_text(data = df, aes(label = df$Quantity, y = 0), vjust = -0.5, position = position_dodge2(0.9)) +
scale_fill_discrete(name = "Title", labels = c("F", "M")) +
facet_wrap(~ df$Entrance, nrow = 1, strip.position = "bottom") +
xlab("Distribution of residents by entrances, taking into account gender") +
ylab("Number of residents") +
theme(
strip.placement = "outside",
strip.background = element_blank(),
axis.text.x = element_blank(),
axis.ticks.x = element_blank()
)
#?(ZMlength ~ Month, data = dat[dat$Lake == LAKE, ],
# main = "", xlab = "Month", ylab = "Shell length (mm)")
})
}
# Run the application
shinyApp(ui = ui, server = server)
What problems did I not solve:
I would like to immediately calculate the maximum and minimum values in the "Age" column when opening a file and change the settings for sliderInput. I would like to do the same with selectInput.
I would like to use the Saini application not only to analyze the downloaded data, but also to replenish the CSV file. In this part, I do not know anything at all.

checkboxInput value R shiny: if TRUE then

I have the following code. The objective is to make the position of the plot bars reactive to the selectInput value
library(shiny)
library(shinyWidgets)
library(tidyverse)
library(DT)
library(shinythemes)
library(plotly)
library(ggthemes)
library(lubridate)
data <- data.frame(mitarbeiter = c("AA", "BB", "CC", "DD", "EE", "FF"),
art = c("hr", "GG", "TT", "RR", "OO", "OO"),
creadate = as_date(c("2018-01-03", "2018-01-03", "2018-01-03", "2018-01-03", "2018-01-03", "2018-01-03")))
mitarbeiter1 <- sort(unique(data$mitarbeiter))
art1 <- sort(unique(data$art))
year_month <- function(dates) {
paste(lubridate::year(dates),
str_pad(lubridate::month(dates), width = 2, pad = 0),
sep="-")
}
year_week <- function(dates) {
paste(lubridate::year(dates),
str_pad(lubridate::week(dates), width = 2, pad = 0),
sep="-")
}
year_day <- function(dates) {
paste(lubridate::year(dates),
str_pad(lubridate::month(dates), width = 2, pad = 0),
str_pad(lubridate::day(dates), width = 2, pad = 0),
sep="-")
}
ui <- fluidPage(
fluidRow(
column(4,
pickerInput("mitarbeiterName", "Name des Mitarbeiters", mitarbeiter1,
options = list(`actions-box` = TRUE), multiple = TRUE),
pickerInput("artName", "Art", art1,
options = list(`actions-box` = TRUE), multiple = TRUE),
pickerInput("period", "Zeitraum", c("day", "week", "month", "year"),
options = list(`actions-box` = TRUE)),
dateRangeInput("date", "Datum auswahlen", start = "2020-01-01"),
checkboxInput("kumulativ", "Kumulativ"),
downloadButton("download", "Download")
),
column(8,
plotlyOutput("policyPlot")
)
)
)
server <- function(input, output, session) {
#create a reactive object with a NULL starting value
listofrows <- reactiveValues(data = NULL)
#observe the changes in inputs and update the reactive object
observeEvent(c(input$mitarbeiterName, input$artName, input$date, input$period), {
req(input$mitarbeiterName)
req(input$artName)
req(input$period)
req(input$date)
listofrows$data <- subset(data, mitarbeiter %in% input$mitarbeiterName &
art %in% input$artName &
creadate >= input$date[1] & creadate <= input$date[2])
}, ignoreInit = T, ignoreNULL = TRUE)
output$policyPlot <- renderPlotly({
req(listofrows$data)
req(input$kumulativ)
fn <- switch(
input$period,
day = year_day,
week = year_week,
month = year_month,
year = year
)
pos <- if (input$kumulativ) "dodge" else "identity"
ggplot(listofrows$data) +
geom_bar(aes(x = fn(creadate), fill = mitarbeiter),
stat = "count",
position = pos,
show.legend = T) +
ggtitle("Anzahl erstellte Policen (pro Mitarbeiter)") +
xlab("Zeitraum") + ylab("Anzahl der Policen")
})
output$download <- downloadHandler(
filename = function() {
paste("data-", Sys.Date(), ".png", sep = "")
},
content = function(file) {
ggsave(file, plot = output$policyPlot)
})
}
shinyApp(ui, server)
Now, I want:
the position to be "dodge" if checkboxInput = TRUE, and
the position to be "identity" if checkboxInput = FALSE.
does someone have any suggestion how to do that? How can we do the if condition with the checkbox value?
In your case, req(input$kumulativ) doesn't work. It's because req checks if a value is "truthy", and FALSE is not considered truthy. Therefore, you can change it to:
req(!is.null(input$kumulativ))

Scatter mapbox in shiny R will not render

I have been working on this shiny app for a while and it all seems to work till i get to the end. It is supposed to output a interactive scatter plot. Well I can get the plot to the point that it has a legend and the hover text pops up on a white blank background, but i am missing the visual points and the map. Outside of shiny i can make the plotly work just fine and i get my mapbox map and scatter plots. I have tired quite a few things but am still failing to render the points and the map. Is there a quark in shiny holding my map back from rendering with the points that i am missing here?
I also am getting this error that goes away when i remove the size or color function from my plot.
Error:
Warning: `line.width` does not currently support multiple values.
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( "Data Frame",
fluidRow(box(DT::dataTableOutput("contents"))),
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("County Plot", plotlyOutput(
"plotMap", height = 1000, width = 1400
),
actionButton("btn", "Plot")
)
)
)
)
)
Server:
server <- function(input, output, session) {
options(shiny.maxRequestSize = 1000*1024^2)
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::renderDT({
withProgress(message = 'loading...', value = 0.1, {
datatab <- datatable(data_set(),
options = list(
"pageLength" = 10,
scrollX = TRUE))
extensions = 'Responsive'
setProgress(1)
datatab
})
})
observeEvent(
input$btn,
{
output$plotMap <- renderPlotly({withProgress(message = 'Plotting...', value = 0.1,{
plots <- function(f1){
f1 <- as.data.frame(f1)
f1$Date <- as.POSIXct(f1$Date)
f1$CNorm <- f1$Cell.Sum..Norm.
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 <- f1 %>%
group_by(.dots = c("year", "month", "Cell")) %>%
dplyr::summarise(yearMonth_Max_sum = max(CNorm))
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 <- f1 %>%
group_by(.dots = c("year", "month", "Cell")) %>%
dplyr::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))
f1$qunat <- ifelse((f1$StdDev > q[4:4,1]) & (f1$StdDev < up[1,1]), 1, 0)
z <- group_by(f1, Cell) %>%
dplyr::summarize(Median_Cell = median(CNorm), na.rm = FALSE)
f1 <- inner_join(f1,z, by = c("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
f1$hover <- with(f1,paste("Sum", f1$yearMonth_Max_sum, "/<br>",
"Standard Dev", f1$StdDev, "/<br>",
"Mean", f1$Average, "/<br>",
"Median", f1$Median_Cell, "/<br>",
"Changed", f1$ChangedX, "/<br>",
"Latitude", f1$Lat , "/<br>",
"Longitude", f1$Lon))
f1 <- f1[which(f1$yearMonth_Max_sum < 9000), ]
f1 <<- f1[!duplicated(f1$yearMonth_Max_sum), ]
##################
Sys.setenv('MAPBOX_TOKEN' = '')
Sys.getenv("MAPBOX_TOKEN")
plot <- f1 %>%
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 = ~f1$hover) %>%
layout(title = "County Plot",
font = list(color = "black"),
mapbox = list(style = "satellite-streets", zoom = 9,
center = list(lat = median(f1$Lat),
lon = median(f1$Lon))))
return(plot)
}
plots(data_set())
})
})
}
)
}
shinyApp(ui = ui, server = server)

Resources