checkboxInput value R shiny: if TRUE then - r

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))

Related

Non-reactive legend in Shiny

How can I create a static legend in this Shiny App?
The legend must contain all 4 anomaly factor levels, regardless if they are present in the reactive plot. The factor levels are NORMAL, TENTATIVE, LOW, and HIGH
The input data-frame is automatically created in the script below.
The color and shape of the legend points and plot points should match.
I also must keep the hover information presently coded into the aes_string()
# Load libraries
library(dplyr)
library(shiny)
library(plotly)
library(ggplot2)
library(dplyr)
library(scales)
library(shinyWidgets)
library(lubridate)
# Create input dataframe
DF <- data.frame(
recordID = as.factor(c(101, 102, 103, 104, 105, 106, 107, 108)),
Category = as.factor(c('X', 'X', 'Z', 'Z', 'Z', 'Z', 'X', 'X')),
CategoryTRUEFALSE = c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE),
startDate = as_date(c('2022-01-01', '2022-01-02', '2022-01-03','2022-01-04', '2015-08-18', '2015-08-19', '2015-08-20','2015-08-21')),
companyName = as.factor(c('CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyA', 'CompanyA', 'CompanyA', 'CompanyA')),
wayPoint = as.factor(c('WP1', 'WP1', 'WP1', 'WP1', 'WP2', 'WP2', 'WP2', 'WP2')),
Capacity = c(8000, 8000, 8000, 8000 , 13000, 13000, 13000, 13000),
finalDestination = as.factor(c('PortA', 'PortA', 'PortA', 'PortA', 'PortB', 'PortB', 'PortB', 'PortB')),
Duration = (c(15, 17, 16, 40, 109, 111, 125, 177)),
Anomaly = (c('NORMAL', 'LOW', 'NORMAL', 'HIGH', 'NORMAL', 'TENTATIVE', 'NORMAL', 'HIGH'))
) %>%
mutate(Anomaly = factor(Anomaly, levels = c('NORMAL', 'TENTATIVE', 'LOW', 'HIGH')))
# Info columns
VARS_info <- c('recordID', 'startDate', 'Category', 'CategoryTRUEFALSE', 'Duration', 'Anomaly')
# Declare selector variables
VARS_selector <- c('companyName', 'wayPoint', 'Capacity', 'finalDestination')
# UI
ui <- navbarPage(title = "Anomaly Browser",
tabPanel("Browse data",
sidebarLayout(
sidebarPanel(
selectInput(inputId = "companyName",
label = "Rail haul provider: ",
choices = sort(unique(Shiny$companyName)),
multiple = FALSE),
selectInput(inputId = "wayPoint",
label = "Load point: ",
choices = NULL,
multiple = FALSE),
selectInput(inputId = "capacity",
label = "Capacity: ",
choices = NULL,
multiple = FALSE),
selectInput(inputId = "finalDestination",
label = "Terminal: ",
choices = NULL,
multiple = FALSE),
br(),
br(),
switchInput(inputId = "category",
onLabel = "X",
offLabel = "Z",
onStatus = "GreenStatus",
offStatus = "RedStatus",
inline = TRUE,
value = TRUE,
size = 'large'
),
br(),
br(),
downloadLink("downloadData", "Download plot data"),
br(),
width = 2,
# switchInput color while on
tags$head(tags$style(HTML('.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-GreenStatus,
.bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-GreenStatus {
background: green;
color: white;
}'))),
# switchInput color while off
tags$head(tags$style(HTML('.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-RedStatus,
.bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-RedStatus {
background: darkred;
color: white;
}'))),
),
mainPanel(
plotlyOutput(outputId = "scatterplot", width = "120%", height = "800px"),
DT::dataTableOutput(outputId = "Table1", width = "125%")
))))
# Server
server <- function(input, output, session) {
observeEvent(input$companyName,{
updateSelectInput(session,'wayPoint',
choices=sort(unique(Shiny$wayPoint[Shiny$companyName %in% input$companyName])))
})
observeEvent(input$wayPoint,{
updateSelectInput(session,'capacity',
choices=sort(unique(Shiny$Capacity[Shiny$wayPoint %in% input$wayPoint &
Shiny$companyName %in% input$companyName])))
})
observeEvent(input$capacity,{
updateSelectInput(session,'finalDestination',
choices=sort(unique(Shiny$finalDestination[Shiny$Capacity == input$capacity &
Shiny$wayPoint %in% input$wayPoint &
Shiny$companyName %in% input$companyName])))
})
observeEvent(input$wayPoint,{
updateSelectInput(session,'finalDestination',
choices=sort(unique(Shiny$finalDestination[Shiny$Capacity == input$capacity &
Shiny$wayPoint %in% input$wayPoint &
Shiny$companyName %in% input$companyName])))
})
observeEvent(input$finalDestination,{
updateSelectInput(session,'category',
choices=sort(unique(Shiny$Category[Shiny$finalDestination %in% input$finalDestination &
Shiny$Capacity == input$capacity &
Shiny$wayPoint %in% input$wayPoint &
Shiny$companyName %in% input$companyName])))
})
# Selected
selected1 <- reactive({
req(input$companyName, input$wayPoint, input$capacity, input$finalDestination)
Shiny %>%
select(all_of(VARS_info), all_of(VARS_selector)) %>%
filter(companyName %in% input$companyName &
wayPoint %in% input$wayPoint &
Capacity == input$capacity &
finalDestination %in% input$finalDestination &
CategoryTRUEFALSE %in% input$category) %>%
select(-CategoryTRUEFALSE)
})
# Create scatterplot object the plotOutput function is expecting
output$scatterplot <- renderPlotly({
p <- ggplot(data = selected1(), aes_string("startDate", "Duration",
A = "startDate", B = "Duration", C = "recordID", D = 'Anomaly'))
p <- p + ggtitle(paste0(input$companyName, " - ", input$wayPoint, " - ", input$finalDestination, " - ", input$capacity, " (", unique(selected1()$Category), ")")) +
xlab('Cycle Start Date') + ylab("Duration (mins)") + theme(text = element_text(size = 13))
p <- p + scale_x_date(date_breaks = "months", date_labels = "%b-%Y") +
geom_smooth(method = "gam", formula = y ~ s(x, bs = "cs", k = 1), colour = "black", lwd = 0.7, se = FALSE)
p <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='NORMAL'),],
pch=21, fill= NA, size=1.0, colour="darkgreen", stroke=1.5)
p <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='TENTATIVE'),],
pch=21, fill= NA, size=1.0, colour="royalblue3", stroke=1.5)
p <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='LOW'),],
pch=21, fill= NA, size=1.0, colour="orange", stroke=1.5)
p <- p + geom_point(data = selected1()[which(selected1()$Anomaly=='HIGH'),],
pch=21, fill= NA, size=1.0, colour="red", stroke=1.5)
ggplotly(p, tooltip = c("A", "B", "C", "D"))
})
# Data table Tab-1
output$Table1 <- DT::renderDataTable({
DT::datatable(data = selected1(),
options = list(pageLength = 20),
rownames = FALSE)
})
# Save CSV
output$downloadData <- downloadHandler(
filename = function() {paste0(input$companyName,'_',input$wayPoint,'_',input$finalDestination,'_',unique(selected1()$Category),'_','cap=',input$capacity,'.csv')},
content = function(file) {
write.csv(selected1(), file, row.names = FALSE)
})
}
# Create a Shiny app object
shinyApp(ui = ui, server = server)
We can force ggplot to display all legend items by providing a dummy data.frame containing all levels available in the dataset.
Furthermore, I'm using scale_colour_manual to reduce the code:
# Load libraries
library(dplyr)
library(shiny)
library(plotly)
library(ggplot2)
library(dplyr)
library(scales)
library(shinyWidgets)
library(lubridate)
# Create input dataframe
DF <- data.frame(
recordID = as.factor(c(101, 102, 103, 104, 105, 106, 107, 108)),
Category = as.factor(c('X', 'X', 'Z', 'Z', 'Z', 'Z', 'X', 'X')),
CategoryTRUEFALSE = c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE),
startDate = as_date(c('2022-01-01', '2022-01-02', '2022-01-03','2022-01-04', '2015-08-18', '2015-08-19', '2015-08-20','2015-08-21')),
companyName = as.factor(c('CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyZ', 'CompanyA', 'CompanyA', 'CompanyA', 'CompanyA')),
wayPoint = as.factor(c('WP1', 'WP1', 'WP1', 'WP1', 'WP2', 'WP2', 'WP2', 'WP2')),
Capacity = c(8000, 8000, 8000, 8000 , 13000, 13000, 13000, 13000),
finalDestination = as.factor(c('PortA', 'PortA', 'PortA', 'PortA', 'PortB', 'PortB', 'PortB', 'PortB')),
Duration = (c(15, 17, 16, 40, 109, 111, 125, 177)),
Anomaly = (c('NORMAL', 'LOW', 'NORMAL', 'HIGH', 'NORMAL', 'TENTATIVE', 'NORMAL', 'HIGH'))
) %>% mutate(Anomaly = factor(Anomaly, levels = c('NORMAL', 'TENTATIVE', 'LOW', 'HIGH')))
DF <- with(DF, DF[order(Anomaly),])
dummyDF <- DF[!duplicated(DF$Anomaly),]
dummyDF$startDate <- as.Date(NA)
colours = c("NORMAL" = "darkgreen", "TENTATIVE" = "royalblue3", "LOW" = "orange", "HIGH" = "red")
# Info columns
VARS_info <- c('recordID',
'startDate',
'Category',
'CategoryTRUEFALSE',
'Duration',
'Anomaly')
# Declare selector variables
VARS_selector <- c('companyName', 'wayPoint', 'Capacity', 'finalDestination')
# UI
ui <- navbarPage(title = "Anomaly Browser",
tabPanel("Browse data",
sidebarLayout(
sidebarPanel(
selectInput(
inputId = "companyName",
label = "Rail haul provider: ",
choices = sort(unique(DF$companyName)),
multiple = FALSE
),
selectInput(
inputId = "wayPoint",
label = "Load point: ",
choices = NULL,
multiple = FALSE
),
selectInput(
inputId = "capacity",
label = "Capacity: ",
choices = NULL,
multiple = FALSE
),
selectInput(
inputId = "finalDestination",
label = "Terminal: ",
choices = NULL,
multiple = FALSE
),
br(),
br(),
switchInput(
inputId = "category",
onLabel = "X",
offLabel = "Z",
onStatus = "GreenStatus",
offStatus = "RedStatus",
inline = TRUE,
value = TRUE,
size = 'large'
),
br(),
br(),
downloadLink("downloadData", "Download plot data"),
br(),
width = 2,
# switchInput color while on
tags$head(tags$style(
HTML(
'.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-GreenStatus,
.bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-GreenStatus {
background: green;
color: white;
}'
)
)),
# switchInput color while off
tags$head(tags$style(
HTML(
'.bootstrap-switch .bootstrap-switch-handle-off.bootstrap-switch-RedStatus,
.bootstrap-switch .bootstrap-switch-handle-on.bootstrap-switch-RedStatus {
background: darkred;
color: white;
}'
)
)),
),
mainPanel(
plotlyOutput(
outputId = "scatterplot",
width = "120%",
height = "800px"
),
DT::dataTableOutput(outputId = "Table1", width = "125%")
)
)))
# Server
server <- function(input, output, session) {
observeEvent(input$companyName, {
updateSelectInput(session, 'wayPoint',
choices = sort(unique(DF$wayPoint[DF$companyName %in% input$companyName])))
})
observeEvent(input$wayPoint, {
updateSelectInput(session, 'capacity',
choices = sort(unique(DF$Capacity[DF$wayPoint %in% input$wayPoint &
DF$companyName %in% input$companyName])))
})
observeEvent(input$capacity, {
updateSelectInput(session, 'finalDestination',
choices = sort(unique(DF$finalDestination[DF$Capacity == input$capacity &
DF$wayPoint %in% input$wayPoint &
DF$companyName %in% input$companyName])))
})
observeEvent(input$wayPoint, {
updateSelectInput(session, 'finalDestination',
choices = sort(unique(DF$finalDestination[DF$Capacity == input$capacity &
DF$wayPoint %in% input$wayPoint &
DF$companyName %in% input$companyName])))
})
observeEvent(input$finalDestination, {
updateSelectInput(session, 'category',
choices = sort(unique(DF$Category[DF$finalDestination %in% input$finalDestination &
DF$Capacity == input$capacity &
DF$wayPoint %in% input$wayPoint &
DF$companyName %in% input$companyName])))
})
# Selected
selected1 <- reactive({
req(input$companyName,
input$wayPoint,
input$capacity,
input$finalDestination)
DF %>%
select(all_of(VARS_info), all_of(VARS_selector)) %>%
filter(
companyName %in% input$companyName &
wayPoint %in% input$wayPoint &
Capacity == input$capacity &
finalDestination %in% input$finalDestination &
CategoryTRUEFALSE %in% input$category
) %>%
select(-CategoryTRUEFALSE)
})
# Create scatterplot object the plotOutput function is expecting
output$scatterplot <- renderPlotly({
p <- ggplot(
data = dummyDF,
aes(x = startDate, y = Duration, color = Anomaly, A = startDate, B = Duration, C = recordID, D = Anomaly)
) + geom_point(
pch = 21,
fill = NA,
size = 1.0,
stroke = 1.5
) + geom_point(
data = selected1(),
pch = 21,
fill = NA,
size = 1.0,
stroke = 1.5
) + scale_colour_manual(values = colours)
p <- p + ggtitle(
paste0(
input$companyName,
" - ",
input$wayPoint,
" - ",
input$finalDestination,
" - ",
input$capacity,
" (",
unique(selected1()$Category),
")"
)
) +
xlab('Cycle Start Date') + ylab("Duration (mins)") + theme(text = element_text(size = 13))
p <- p + scale_x_date(date_breaks = "months", date_labels = "%b-%Y") +
geom_smooth(
method = "gam",
formula = y ~ s(x, bs = "cs", k = 1),
colour = "black",
lwd = 0.7,
se = FALSE
)
ggplotly(p, tooltip = c("A", "B", "C", "D")) %>% layout(legend = list(
itemclick = FALSE,
itemdoubleclick = FALSE,
groupclick = FALSE,
itemsizing = "constant",
itemwidth = 100
# x = [...],
# xanchor = [...],
# y = [...],
# yanchor = [...]
))
})
# Data table Tab-1
output$Table1 <- DT::renderDataTable({
DT::datatable(
data = selected1(),
options = list(pageLength = 20),
rownames = FALSE
)
})
# Save CSV
output$downloadData <- downloadHandler(
filename = function() {
paste0(
input$companyName,
'_',
input$wayPoint,
'_',
input$finalDestination,
'_',
unique(selected1()$Category),
'_',
'cap=',
input$capacity,
'.csv'
)
},
content = function(file) {
write.csv(selected1(), file, row.names = FALSE)
}
)
}
# Create a Shiny app object
shinyApp(ui = ui, server = server)
I also provided a layout call on ggplotly to avoid legend clicks, to have a fully static legend. Not sure if this is needed, though.
Regarding the legend position please run schema() and navigate:
object ► layout ► layoutAttributes ► legend ► x
for more information on the parameters, e.g.:
Sets the x position (in normalized coordinates) of the legend.
Defaults to 1.02 for vertical legends and defaults to 0 for
horizontal legends.
Here a related post concerning the legend item size can be found.

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 R shiny. Insert a condition

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)

reactive value resets to NA when new row inserted rhandsontable shiny

I have a Shiny app with a rhandsontable and an infobox which reports the remaining budget, based on an initial budget (1000) and the values users put in the rhandsontable.
The value of the remaining budget updates correctly based on the value of the W column, however, when inserting a new row the value first changes to NA, before it gets recomputed, based on the value entered.
I would like to value of the Remaining Budget infobox to stay the same until the new values are added. Below my code:
library(shiny)
library(rhandsontable)
library(dplyr)
library(shinydashboard)
ui <- fluidPage( fluidRow(column(6, uiOutput("selA"))),
fluidRow(column(6, rHandsontableOutput('tbl1'))),
fluidRow(column(6,box(title = "Remaining budget", width = 6, status = "info",
textOutput("infoRestBudget"))))
)
server <- function(input, output, session){
dt0 <- data.frame( A = c("S2","S2","S2","S4","S4","S4"),
B = c("1","2","3","1","2","3"),
C = c(10,20,30,40,15,25),
D = c("A","B","C","D","E","F"))
# get the data for the selected BA
dt <- reactive(subset(dt0, A %in% input$selA))
# Render selectInput selBA
output$selA <- renderUI({
ba <- as.vector( unique(dt0$A) )
selectInput("selA","Choose BA", choices = ba)
})
DF <- data.frame("X" = c(""),
"Y" = c(""),
"Z" = c(""),
"Type_action" = c(""),
"W" = NA_integer_)
values <- reactiveValues(data = DF)
Y <- reactiveVal()
Z <- reactiveVal()
observe({
if(!is.null(input$tbl1)){
values$data <- as.data.frame(hot_to_r(req(input$tbl1)))
}
})
observeEvent(input$tbl1,{
Y(hot_to_r(input$tbl1)$Y)},
ignoreInit= TRUE
)
observeEvent(input$tbl1,{
Z(hot_to_r(input$tbl1)$Z)},
ignoreInit= TRUE
)
output$tbl1 = renderRHandsontable({
req(input$selA)
tmpTable <- rhandsontable(values$data, rowHeaders = FALSE, selectCallback = TRUE, width =
1000, height = 200) %>%
hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>%
hot_col(col = "X", type = "dropdown", colWidths = 90, source =
sort(unique(dt()$B))) %>%
hot_col(col = "Y", type = "dropdown", colWidths = 65, source =
sort(unique(dt()$D))) %>%
hot_col(col = "Z", type = "dropdown", colWidths = 60,source =
sort(unique(dt()$D))) %>%
hot_col(col = "Type_action", colWidths = 50, readOnly = TRUE, type = "text") %>%
hot_col(col = "W", colWidths = 50, readOnly = TRUE, type = "numeric")
if(!is.null(input$tbl1_select$select$r) && !is.na(values$data$Y[input$tbl1_select$select$r])
&& !is.na(values$data$Z[input$tbl1_select$select$r])){
values$data$Type_action <- ifelse(match(Y(), LETTERS) < match(Z(), LETTERS),"Upgrade","Downgrade")
if(!is.null(input$tbl1_select$select$r) && !is.na(values$data$Y[input$tbl1_select$select$r])
&& !is.na(values$data$Z[input$tbl1_select$select$r])){
val <- 100
values$data$W <- ifelse((match(Y(), LETTERS) < match(Z(), LETTERS)), val, -val)
}
}
tmpTable
})
val_W <- reactiveVal()
observeEvent(input$tbl1,{
val_W(hot_to_r(input$tbl1)$W)},
ignoreInit= TRUE
)
budget <- 1000
restBudget <- reactiveValues(val = budget)
observeEvent(input$tbl1, {
if(is.null(input$tbl1)){
restBudget$val <- budget} else{
restBudget$val <- budget - sum(as.numeric(val_W()))
}
}, ignoreInit = TRUE)
output$infoRestBudget <- renderText({
req(input$tbl1)
euro <- "\u20AC"
res <- paste(euro, "", restBudget$val)
res
})
}
shinyApp(ui, server)
Try the code below. You are getting NA because the new rows appear with no data in them. When there is an NA in X, Y, or Z "Remaining Budget" is NA because it needs non-NA values to be calculated. When you add a new row you introduce NAs to the calculation so it becomes NA.
The solution is to set default values for your new rows. In the hot_col(...) objects you can set a default value for columns in new rows.
I have set X = 1, Y = A, Z = A but use whatever you think is best for your application.
library(shiny)
library(rhandsontable)
library(dplyr)
library(shinydashboard)
ui <- fluidPage( fluidRow(column(6, uiOutput("selA"))),
fluidRow(column(6, rHandsontableOutput('tbl1'))),
fluidRow(column(6,box(title = "Remaining budget", width = 6, status = "info",
textOutput("infoRestBudget"))))
)
server <- function(input, output, session){
dt0 <- data.frame( A = c("S2","S2","S2","S4","S4","S4"),
B = c("1","2","3","1","2","3"),
C = c(10,20,30,40,15,25),
D = c("A","B","C","D","E","F"))
# get the data for the selected BA
dt <- reactive(subset(dt0, A %in% input$selA))
# Render selectInput selBA
output$selA <- renderUI({
ba <- as.vector( unique(dt0$A) )
selectInput("selA","Choose BA", choices = ba)
})
DF <- data.frame("X" = c(""),
"Y" = c(""),
"Z" = c(""),
"Type_action" = c(""),
"W" = NA_integer_)
values <- reactiveValues(data = DF)
Y <- reactiveVal()
Z <- reactiveVal()
observe({
if(!is.null(input$tbl1)){
values$data <- as.data.frame(hot_to_r(req(input$tbl1)))
}
})
observeEvent(input$tbl1,{
Y(hot_to_r(input$tbl1)$Y)},
ignoreInit= TRUE
)
observeEvent(input$tbl1,{
Z(hot_to_r(input$tbl1)$Z)},
ignoreInit= TRUE
)
output$tbl1 = renderRHandsontable({
req(input$selA)
tmpTable <- rhandsontable(values$data, rowHeaders = FALSE, selectCallback = TRUE, width =
1000, height = 200) %>%
hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>%
hot_col(col = "X", type = "dropdown", colWidths = 90, default = "1" , source =
sort(unique(dt()$B))) %>%
hot_col(col = "Y", type = "dropdown", colWidths = 65, default = "A", source =
sort(unique(dt()$D))) %>%
hot_col(col = "Z", type = "dropdown", colWidths = 60, default = "A", source =
sort(unique(dt()$D))) %>%
hot_col(col = "Type_action", colWidths = 50, readOnly = TRUE, type = "text") %>%
hot_col(col = "W", colWidths = 50, readOnly = TRUE, type = "numeric")
if(!is.null(input$tbl1_select$select$r) && !is.na(values$data$Y[input$tbl1_select$select$r])
&& !is.na(values$data$Z[input$tbl1_select$select$r])){
values$data$Type_action <- ifelse(match(Y(), LETTERS) < match(Z(), LETTERS),"Upgrade","Downgrade")
if(!is.null(input$tbl1_select$select$r) && !is.na(values$data$Y[input$tbl1_select$select$r])
&& !is.na(values$data$Z[input$tbl1_select$select$r])){
val <- 100
values$data$W <- ifelse((match(Y(), LETTERS) < match(Z(), LETTERS)), val, -val)
}
}
tmpTable
})
val_W <- reactiveVal()
observeEvent(input$tbl1,{
val_W(hot_to_r(input$tbl1)$W)},
ignoreInit= TRUE
)
budget <- 1000
restBudget <- reactiveValues(val = budget)
observeEvent(input$tbl1, {
if(is.null(input$tbl1)){
restBudget$val <- budget} else{
restBudget$val <- budget - sum(as.numeric(val_W()))
}
}, ignoreInit = TRUE)
output$infoRestBudget <- renderText({
req(input$tbl1)
euro <- "\u20AC"
res <- paste(euro, "", restBudget$val)
res
})
}
shinyApp(ui, server)

Table will not render in Shiny

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
})

Resources