Rendering a shiny datatable with a caption/title and pre-selected rows - r

I'm trying to code a shiny app for plotting xy data. Each xy point is associated with several factors:
set.seed(1)
data.df <- data.frame(x = rnorm(1000), y = rnorm(1000),
sex = sample(c("F", "M"), 1000, replace = T),
age = sample(c("Y", "O"), 1000, replace = T),
group = sample(c("A", "B", "C", "D"), 1000, replace = T),
stringsAsFactors = F)
design.df <- data.frame(factor.name = c(c(rep("sex",2), rep("age",2), rep("group",4))),
factor.levels = c("F", "M","Y", "O","A", "B", "C", "D"), stringsAsFactors = F)
I would like to enable the user to subset the xy data (data.df) based on a selection of multiple rows from design.df using DT::renderDT within renderUI in the server, where the default selection is all rows of design.df. This works fine using this code:
suppressPackageStartupMessages(library(dplyr))
suppressPackageStartupMessages(library(shiny))
suppressPackageStartupMessages(library(DT))
server <- function(input, output)
{
output$design.idx <- renderUI({
output$design.df <- DT::renderDT(design.df, server = TRUE, selection = list(mode = "multiple", selected = rownames(design.df)[1:nrow(design.df)]))
DT::dataTableOutput("design.df")
})
xy.plot <- reactive({
if(!is.null(input$design.df_rows_selected)){
selected.design.df <- design.df[input$design.df_rows_selected,,drop = FALSE]
selected.idx <- lapply(unique(selected.design.df$factor.name), function(f) which(data.df[,f] %in% dplyr::filter(selected.design.df, factor.name == f)$factor.levels)) %>%
unlist() %>% unique()
plot.df <- data.df[selected.idx,,drop=F]
xy.plot <- suppressWarnings(plotly::plot_ly(marker = list(size = 3), type = 'scatter', mode = "markers", x = plot.df$x, y = plot.df$y, showlegend = FALSE) %>%
plotly::layout(xaxis = list(zeroline = FALSE, showticklabels = FALSE, showgrid = FALSE), yaxis = list(zeroline = FALSE, showticklabels = FALSE, showgrid = FALSE)))
} else{
xy.plot <- NULL
}
return(xy.plot)
})
output$outPlot <- plotly::renderPlotly({
xy.plot()
})
}
ui <- fluidPage(
titlePanel("Results Explorer"),
sidebarLayout(
sidebarPanel(
uiOutput("design.idx")
),
mainPanel(
plotly::plotlyOutput("outPlot")
)
)
)
shinyApp(ui = ui, server = server)
But I would also like to have a title or caption for the rendered datatable, so I tried replacing:
output$design.df <- DT::renderDT(design.df, server = TRUE, selection = list(mode = "multiple", selected = rownames(design.df)[1:nrow(design.df)]))
with:
output$design.df <- DT::renderDT(datatable(design.df, caption = "Subset Selection"), server = TRUE, selection = list(mode = "multiple", selected = rownames(design.df)[1:nrow(design.df)]))
in which case the selected = rownames(design.df)[1:nrow(design.df)] argument seems to be ignored and the default selection is no rows.
Changing selected = rownames(design.df)[1:nrow(design.df)] to selected = 1:nrow(design.df) makes no difference.
Any idea how to get both a title or caption to the rendered table together with have all rows as a pre-selection default?

You have to put selection in the datatable object:
output$design.df <- DT::renderDT(
datatable(design.df,
caption = "Subset Selection",
selection = list(mode = "multiple",
selected = rownames(design.df)[1:nrow(design.df)])
),
server = TRUE)

Related

R shiny: How to copy data derived from plotly_selection events into a data frame/table and update each time by pressing an actionButton?

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

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.

Dynamic filters shiny app with equal/common levels

I'm trying to have an app with 3 dynamic filters where each filter is a subset of the previous.
I have partial success, however, since I have similar levels/factors for some of the data it seems this causing an issue with my filters outcome.
I can't seem to figure out how to solve the issue with the common levels for the "Spot" attribute.
Does anyone have any feedback?
Thanks!
My app:
library(rstudioapi)
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(shinyjs)
library(shinyWidgets)
library(readxl)
library(DT)
library(devtools)
library(dplyr)
library(tidyr)
library(tidyverse)
library(rgl)
library(rglwidget)
col_1 <- c("A1","A1","A1", "A2", "A2", "B1", "B2", "C1","C1","C1")
col_2 <- c("a", "b", "c", "d", "e", "a", "b", "a", "b", "c")
col_3 <- c("Benz", "Audi", "Renault", "Ferrari", "Porsche", "Mercedes", "Benz", "Benz", "Audi", "Renault")
data_1 <- data.frame(col_1, col_2, col_3, stringsAsFactors = TRUE)
colnames(data_1) <- c("Building", "Spot", "Car")
server <- function(input, output, session) {
filterCars <- reactive({
filterCar <- data_1
filterCar <- droplevels.data.frame(filterCar)
return(filterCar)
})
filterBuilding <- reactive({
unique(as.character(filterCars()$Building))
})
output$filterBuilding <- renderUI({
pickerInput(inputId = 'filter_Building', 'Building',
choices = sort(filterBuilding()),
multiple = TRUE,
width = "1250px",
options = list(`actions-box` = TRUE),
selected = sort(as.character(filterCars()$Building)))
})
# # Subset dynamically the previous reactive filter #
datasub1 <- reactive({
data_1[data_1$Building == input$filter_Building,]
})
filterSpot <- reactive({
unique(as.character(datasub1()$Spot))
})
output$filterSpot <- renderUI({
pickerInput(inputId = 'filter_Spot', 'Spot',
choices = sort(filterSpot()),
multiple=TRUE,
width = "1250px",
options = list(`actions-box` = TRUE),
selected = sort(as.character(filterCars()$Spot)))
})
# Subset dynamically the previous reactive filter #
datasub2 <- reactive({
data_1[data_1$Spot == input$filter_Spot,]
})
filterBrand <- reactive({
unique(as.character(datasub2()$Car))
})
output$filterBrand <- renderUI({
pickerInput(inputId = 'filter_Brand', 'ID',
choices = sort(filterBrand()),
multiple = TRUE,
width = "1250px",
selected = NULL,
options = list("max-options" = 4, `actions-box` = TRUE))
})
output$databaseCars <- DT::renderDT({
# Subset for plotly reactivity
Filter1 <- droplevels.data.frame(data_1)
Filter2 <- filter(Filter1,
Filter1$Building %in% input$filter_Building,
Filter1$Spot %in% input$filter_Spot,
Filter1$Car %in% input$filter_Brand)
# Plot
datatable(Filter2,
filter="none",
selection="none",
escape=FALSE,
rownames = FALSE,
# colnames = c("", ""),
autoHideNavigation = TRUE,
style = 'bootstrap4',
options = list(searching = FALSE, # remove search option
ordering = FALSE, # remove sort option
paging = FALSE, # remove paging
info = FALSE # remove bottom information
)) %>%
formatStyle(columns = 1, fontWeight = 'bold', `text-align` = 'left') # text to bold and lign left in first column
})
}
# User Interface
ui <- fluidPage(
mainPanel(
fluidRow(
column(12,
uiOutput("filterBuilding")
)),
fluidRow(
column(12,
uiOutput("filterSpot")
)),
fluidRow(
column(12,
uiOutput("filterBrand")
)),
p(DTOutput('databaseCars'))
)
)
shinyApp(ui, server)
A few issues I've spotted:
you can have several factors/selections per variable, therefore you need to use %in% instead of == for the filtering
for the brands, you've set selected = NULL, therefore no brand was selected by default
in general, it is recommend to create the UI elements in the ui part and update them with updatePickerInput instead of using renderUI, because then all rendering has to be done server side, which can slow the app down (especially if you have a several parallel users, as it is only served by one R process
Here is my take:
library(shiny)
library(DT)
library(dplyr)
library(shinyWidgets)
col_1 <- c("A1","A1","A1", "A2", "A2", "B1", "B2", "C1","C1","C1")
col_2 <- c("a", "b", "c", "d", "e", "a", "b", "a", "b", "c")
col_3 <- c("Benz", "Audi", "Renault", "Ferrari", "Porsche", "Mercedes", "Benz", "Benz", "Audi", "Renault")
data_1 <- data.frame(col_1, col_2, col_3, stringsAsFactors = TRUE)
colnames(data_1) <- c("Building", "Spot", "Car")
server <- function(input, output, session) {
filterCars <- reactive({
filterCar <- data_1
filterCar <- droplevels.data.frame(filterCar)
return(filterCar)
})
filterBuilding <- reactive({
unique(as.character(filterCars()$Building))
})
observeEvent(filterBuilding(), {
updatePickerInput(session,
"filter_Building",
choices = filterBuilding(),
selected = sort(filterBuilding()))
})
# # Subset dynamically the previous reactive filter #
datasub1 <- reactive({
data_1[data_1$Building %in% input$filter_Building,]
})
filterSpot <- reactive({
unique(as.character(datasub1()$Spot))
})
observeEvent(filterSpot(), {
updatePickerInput(session,
"filter_Spot",
choices = sort(filterSpot()),
selected = sort(filterSpot()))
})
# Subset dynamically the previous reactive filter #
datasub2 <- reactive({
# browser()
data_1[data_1$Spot %in% input$filter_Spot,]
})
filterBrand <- reactive({
unique(as.character(datasub2()$Car))
})
observeEvent(filterBrand(), {
updatePickerInput(session,
"filter_Brand",
choices = sort(filterBrand()),
selected = sort(filterBrand()))
})
output$databaseCars <- DT::renderDT({
# Subset for plotly reactivity
Filter1 <- droplevels.data.frame(data_1)
Filter2 <- filter(Filter1,
Filter1$Building %in% input$filter_Building,
Filter1$Spot %in% input$filter_Spot,
Filter1$Car %in% input$filter_Brand)
# Plot
datatable(Filter2,
filter="none",
selection="none",
escape=FALSE,
rownames = FALSE,
# colnames = c("", ""),
autoHideNavigation = TRUE,
style = 'bootstrap4',
options = list(searching = FALSE, # remove search option
ordering = FALSE, # remove sort option
paging = FALSE, # remove paging
info = FALSE # remove bottom information
)) %>%
formatStyle(columns = 1, fontWeight = 'bold', `text-align` = 'left') # text to bold and lign left in first column
})
}
# User Interface
ui <- fluidPage(
mainPanel(
fluidRow(
column(12,
pickerInput(inputId = 'filter_Building', 'Building',
choices = NULL,
multiple = TRUE,
width = "1250px",
options = list(`actions-box` = TRUE),
selected = NULL)
)),
fluidRow(
column(12,
pickerInput(inputId = 'filter_Spot', 'Spot',
choices = NULL,
multiple=TRUE,
width = "1250px",
options = list(`actions-box` = TRUE),
selected = NULL)
)),
fluidRow(
column(12,
pickerInput(inputId = 'filter_Brand', 'ID',
choices = NULL,
multiple = TRUE,
width = "1250px",
selected = NULL,
options = list("max-options" = 4, `actions-box` = TRUE))
)),
p(DTOutput('databaseCars'))
)
)
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)

Selecting many items from the list in R

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

Resources