I have an app, which fetches data from an SQL-db, then allows the user to edit it, and this should be saved to the DB. In the repex I have used a CSV-file, but the logic should still be comparable.
However, the data is saved in the session once I edit the column value, but if I switch input or close the app and re-open, it's back to the original. Edits are not reflected in the summary table. What am I doing wrong?
# Load libraries
library(DT)
library(gt)
library(shiny)
library(shinydashboard)
library(dplyr)
# Load data (run once for replication; in real use case will be a DB-connection)
#gtcars_tbl <- gtcars
#write.csv(gtcars_tbl, "gtcars_tbl.csv", row.names = FALSE)
# Simple UI
sidebar <- dashboardSidebar(
sidebarMenu(
menuItem("Summary table", tabName = "summary", icon = icon("project-diagram")),
menuItem("Edit table", tabName = "edit", icon = icon("project-diagram")),
uiOutput("country")
)
)
body <- dashboardBody(
tabItems(
tabItem(tabName = "summary",
h2("Summary of GT Cars"),
gt_output(outputId = "gt_filt_tbl")
),
tabItem(tabName = "edit",
h2("Editer GT Cars"),
DTOutput("edit")
)
)
)
ui <- dashboardPage(
dashboardHeader(title = "GT Cars"),
sidebar,
body)
# Define server functions
server <- function(input, output, session) {
# Load data
gtcars_tbl <- read.csv("gtcars_tbl.csv")
countries <- sort(as.vector(unique(gtcars_tbl$ctry_origin)))
# Create dropdown output
output$country <- renderUI({
selectInput("country", "Country", countries)
})
# Create reactive table
gt_tbl_react <- reactiveVal(NULL)
gt_tbl_react(gtcars_tbl)
# Create filtered table
gt_filt_tbl <- reactive({
req(input$country)
gt_tbl_react() %>%
filter(ctry_origin == input$country)
})
# Render summary table
output$gt_filt_tbl <- render_gt({
gt_filt_tbl() %>%
group_by(ctry_origin, mfr) %>%
summarise(
N = n(),
Avg_HP = mean(hp),
MSRP = mean(msrp)
) %>%
gt(
rowname_col = "ctry_origin",
groupname_col = "mfr")
})
# Render editable table
output$edit <- renderDT(
gt_tbl_react() %>%
filter(ctry_origin == input$country),
selection = 'none', editable = TRUE,
rownames = TRUE,
extensions = 'Buttons'
)
observeEvent(input$edit_cell_edit, {
gtcars_tbl[input$edit_cell_edit$row,input$edit_cell_edit$col] <<- input$edit_cell_edit$value
write.csv(gtcars_tbl, "gtcars_tbl.csv", row.names = FALSE)
})
}
# Run app
shinyApp(ui, server)
The issue is that input$edit_cell_edit$row and input$edit_cell_edit$col are provided according to the subsetted dataframe that is displayed whereas you are changing the values on complete dataframe.
Use this in observeEvent -
observeEvent(input$edit_cell_edit, {
inds <- which(gtcars_tbl$ctry_origin == input$country)
gtcars_tbl[inds[input$edit_cell_edit$row],input$edit_cell_edit$col] <- input$edit_cell_edit$value
write.csv(gtcars_tbl, "gtcars_tbl.csv", row.names = FALSE)
})
Related
So far I made a Shiny app with the following procedures/features:
global.R: Connects to the database using pool in R and retrieves min and max date which will be used in the server side
ui.R: I created two tabs but will only include tab2 here. tab2 has three dropdown inputs and a filtered data table based on these inputs
ui_tab2.R: Defined the three inputs explained in ui.R:
var_lab_tab2: A static dropdown input with only two choices Choice1 and Choice2
daterange_tab2_ui: A date range
subid_dropdown_tab2_ui: The last dropdown input that depends on the first two
server_tab2.R:
Function1 dropdownTab2Server:
Defined the date range logic with id daterange_tab2
Defined the last input dropdown logic with id var_list_tab2
Function2 filteredDataTableTab2Server (This part is not working):
Fetch the filtered data using SQL based on the three inputs
So far everything is working except for filteredDataTableTab2Server which is returning an empty data table. I think the problem is related to the dynamic sql part inside glue_sql. Any help would be of great help.
##### 1st module: global.R
#### Libraries
library(pool)
library(dplyr)
library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinycssloaders)
library(glue)
library(tidyr)
library(DBI)
library(reactable)
library(tidyverse)
#### Source
source("ui_tab2.R", local = T)
source("server_tab2.R", local = T)
# Assume we made our pooled object and saved it as "pool"
min_max_date <- pool %>%
tbl("table1") %>%
summarise(
max_date = max(timestamp, na.rm = T)
)
min_max_date_df <- as.data.frame(min_max_date) %>%
mutate(
min_date = as.Date("2022-01-01"),
max_date = as.Date(max_date)
) %>%
select(c(min_date, max_date))
##### 2nd module: ui.R
dashboardPage(dashboardHeader(
title = "title",
),
dashboardSidebar(
collapsed = F,
sidebarMenu(
menuItem("tab1_title", tabName = "tab1"),
menuItem("tab2_title", tabName = "tab2")
)
),
dashboardBody(
useShinyjs(),
tabItems(
tabItem(
tabName = "tab2",
dropdownTab2UI("dropdown_ui_tab2"),
reactableOutput("table1_tab2"),
)
)
)
)
##### 3rd module: ui_tab2.R
dropdownTab2UI <- function(id) {
ns <- NS(id)
tagList(
div(
shinyWidgets::pickerInput(
ns("var_lab_tab2"),
"ID:",
choices = c("Choice1", "Choice2"),
options = shinyWidgets::pickerOptions(
actionsBox = T,
header = "Close",
liveSearch = T
),
multiple = T
)
),
uiOutput(ns("daterange_tab2_ui")),
uiOutput(ns("subid_dropdown_tab2_ui"))
)
}
###### 4th module: server.R
function(input, output, session) {
dropdownTab2Server("dropdown_ui_tab2")
myvars <- dropdownTab2Server("dropdown_ui_tab2")
# This part is not working. The error message is "Error in as.vector:
# cannot coerce type 'closure' to vector of type 'character'".
# If I remove ```reactive```, then it works but it returns an empty data table.
data_tab2 <- filteredDataTableTab2Server(
id = "table1_tab2",
input1 = reactive(myvars$var1),
input2 = reactive(myvars$var2),
input3 = reactive(myvars$var3)
)
### renderDataTable
output$table1_tab2 <- renderReactable({
reactable(
req(data_tab2())
)
})
}
###### 5th module: server_tab2.R
#### 5-1. A dropdown input dependent on the date range
dropdownTab2Server <- function(id) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
rv <- reactiveValues()
output$daterange_tab2_ui <- renderUI({
req(input$var_lab_tab2)
dateRangeInput(
ns("daterange_tab2"),
"Date Range:",
start = min_max_date_df$min_date,
end = min_max_date_df$max_date
) # Retrieved from "global.R"
})
unique_lists_tab2 <- reactive({
sql <- glue_sql("
SELECT
DISTINCT list AS unique_list
FROM table1
WHERE date BETWEEN date ({dateid1_tab2*}) AND date ({dateid2_tab2*})
",
dateid1_tab2 = input$daterange_tab2[1],
dateid2_tab2 = input$daterange_tab2[2],
.con = pool
)
dbGetQuery(pool, sql)
})
output$subid_dropdown_tab2_ui <- renderUI({
req(input$daterange_tab2[1], input$daterange_tab2[2])
shinyWidgets::pickerInput(
ns("var_list_tab2"),
"Stations:",
choices = unique_lists_tab2(),
options = shinyWidgets::pickerOptions(
actionsBox = T,
header = "Close",
liveSearch = T
),
multiple = T
)
})
observe({
rv$var1 <- input$daterange_tab2[1]
rv$var2 <- input$daterange_tab2[2]
rv$var3 <- input$var_list_tab2
})
return(rv)
}
)
}
#### 5-2. Filtered data based on all inputs => This part is returning an empty data table
filteredDataTableTab2Server <- function(id, input1, input2, input3) {
moduleServer(id, function(input, output, session) {
reactive({
sql <- glue_sql("
SELECT
col1,
col2,
col3
FROM table1
WHERE date BETWEEN date ({dateid_tab2*}) AND date ({dateid_tab2*})
AND system IN ({listid_tab2*})
",
dateid1_tab2 = input1,
dateid2_tab2 = input2,
listid_tab2 = input3,
.con = pool
)
dbGetQuery(pool, sql)
})
}
)
}
You don't evaluate your reactive inputs to the filteredDataTableTab2Server module.
Try:
dateid1_tab2 = input1(),
dateid2_tab2 = input2(),
listid_tab2 = input3(),
I have a shiny module where I want to read one data frame or another based on the user's selection. After the user selects one data frame or another, I want to give the user the option to plot one variable or another using a material switch. Mexico button means that it will be a data frame grouped by states. Municipal button means that it is a data frame grouped by municipality.
I am struggling to connect the material switch with the df selected with the action button. I have just tried with one action button.
Here is the code
require(shiny)
require(ggplot2)
require(dplyr)
require(tidyr)
require(readr)
require(data.table)
require(shinyWidgets)
require(ggplot2)
mod_dfSelector_ui <- function(id){
ns <- NS(id)
fluidRow(
column(2,
actionButton(inputId = ns("mexico_df"),
label = "Mexico")),
column(2,
actionButton(inputId = ns("municipal_df"),
label = "Municipal")),
column(4,
tags$div(
materialSwitch(inputId = "cumdeath", label = "Cumulative sum of covid deaths",
inline = TRUE),
tags$div(
materialSwitch(inputId = "exdeath", label = "Excess mortality",
inline = TRUE)
)
)
),
column(2,
plotOutput(
outputId = ns("plot"))
)
)
}
mod_dfSelector_server <- function(id){
moduleServer(id, function(input, output, session){
ns <- session$ns
# ----- buttons
countryDF <- eventReactive(input$mexico_df,{
fread("../data-raw/mexico-covid-final.csv", header = T) %>%
group_by(id_ent, month_def, year_def) %>%
summarise(tot_covid_deaths = sum(tot_covid_deaths, na.rm = T),
excess_mortality_ssa = sum(excess_mortality_ssa, na.rm = T),
excess_mortality_inegi = sum(excess_mortality_inegi, na.rm = T))
})
municipalDF <- eventReactive(input$municipal_df,{
fread("../data-raw/mexico-covid-final.csv", header = T)
})
# ---- switch
cumulativeEnt <- eventReactive(input$cumdeath, {
countryDF() %>%
select(month_def, year_def, tot_covid_deaths)
})
output$plot <- renderPlot({
cumulativeEnt() %>%
ggplot(aes(tot_covid_deaths)) +
geom_histogram()
})
})
}
## To be copied in the UI
# mod_histogram_ui("histogram_ui_1")
## To be copied in the server
# mod_histogram_server("histogram_ui_1")
ui <- fluidPage(
mod_dfSelector_ui("country")
)
server <- function(input, output, session) {
mod_dfSelector_server("country")
}
shinyApp(ui, server)
I have an editable reactive datatable in R shiny with countries and key values. The rownames in the first column contain regions as well as the value name. I want to provide the users the ability to multi sort the datatable based on rownames, eg: first asc sort on region and then desc sort on val3. I'm unsure on whether DT provides any functionality to multi sort dynamically on row names.
Code:
library(shiny)
library(shinydashboard)
library(tidyverse)
library(DT)
header <- dashboardHeader(title = "My First App")
sidebar <- dashboardSidebar()
body <- dashboardBody(
tabItems(
tabItem(
tabName = 'User View', class = 'active',
fluidRow(
box(
dataTableOutput('userTable'), width = 6
)
)
)
)
)
ui <- dashboardPage(title = 'User View', header, sidebar, body, skin='blue')
server <- function(input, output, session){
dat <- data.frame(US = c("NAmerica","1.1","4.3","2","89","56.8"), CHN = c("Asia","7.8","22","3","0.55","68"), ETH = c("Africa","22","5","9.4","33","1"), CAN = c("NAmerica","75","5.7","33","1","45"),stringsAsFactors = FALSE)
row.names(dat) <- c('region', 'val1', 'val2', 'val3', 'val4', 'val5')
output$userTable <- renderDataTable({
DT::datatable(isolate(dat),
editable = TRUE,
rownames = TRUE,
options=list(
searching = FALSE,
paging = FALSE
))
},server=FALSE)
###Tracking Changes###
rvs <- reactiveValues(
data = NA #dynamic data object
)
observe({
rvs$data <- dat
})
proxy = dataTableProxy('userTable')
observe({
DT::replaceData(proxy, rvs$data, rownames = FALSE, resetPaging = FALSE)
})
observeEvent(input$userTable_cell_edit, {
rvs$data <<- editData(rvs$data, input$userTable_cell_edit, rownames = FALSE)
})
}
shinyApp(ui = ui, server = server)
Current Output:
Desired output for asc sort on region and then desc sort on val3:
Basically looking to recreate custom row sorts in Excel as below:
In the following example I have two static radio buttons representing the mtcars and iris datasets. Upon making a selection, the user is presented with a second set of buttons based on data in each dataset. For the mtcars dataset, the user can filter by selecting from the unique list of carburetors or in the case of the iris dataset, the species. Now, I require another set of buttons based on the carb/species buttons to further filter the data. Say, for the mtcars dataset the list of unique gear selections associated with the carburetor selection and for the Iris the unique set of petal lengths. Given the real world application of what I'm trying to accomplish, there is no getting away from requiring a third set of reactive radio buttons. I just have no clue how to approach the next step.
ui.R
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(title = "My DFS Dashboard"),
dashboardSidebar(
sidebarMenu(
menuItem("MTCARS", tabName = "dashboard", icon = icon("dashboard")),
menuItem("IRIS", tabName = "widgets", icon = icon("th"))
)
),
dashboardBody(
fluidRow (
column(width = 3,
box(title = "Select Dataset", width = NULL, status = "primary", background = "aqua",
radioButtons ("mydataset",
"",
inline = TRUE,
c("mtcars", "iris"),
selected = "mtcars"))),
column(width = 3,
box(title="Select Filter One", width = NULL, status = "primary", background = "aqua",
uiOutput("filter1"))),
column(width = 3,
box(title = "Select Fitler Two", width = NULL, status = "primary", background = "aqua",
uiOutput("filter2")))
)
)
)
server.R
library(tidyverse)
server <- function(input, output, session) {
data("mtcars")
data("iris")
cars <- mtcars
flowers <- iris
carbs <- cars %>%
dplyr::select(carb)
carbs <- carbs$carb
carbs <- as.data.frame(carbs)
carbs <- unique(carbs$carb)
spec <- flowers %>%
dplyr::select(Species)
spec <- unique(spec$Species)
vards <- reactive ({
switch(input$mydataset,
"mtcars" = carbs,
"iris" = spec,
)
})
output$filter1 <- renderUI({
radioButtons("fil1","", choices=vards())
})
}
Perhaps this may be helpful. You can add another reactive expression to filter your dataset and obtain choices for the third set of radio buttons. I included isolate so that the third set of buttons does not react to changes in the dataset (only changes in the second radio buttons, which is dependent already on the dataset). Please let me know if this is what you had in mind for behavior.
server <- function(input, output, session) {
data("mtcars")
data("iris")
cars <- mtcars
flowers <- iris
vards1 <- reactive({
switch(input$mydataset,
"mtcars" = unique(cars$carb),
"iris" = unique(flowers$Species),
)
})
vards2 <- reactive({
req(input$fil1)
if (isolate(input$mydataset) == "mtcars") {
cars %>%
filter(carb == input$fil1) %>%
pull(gear) %>%
unique()
} else {
flowers %>%
filter(Species == input$fil1) %>%
pull(Petal.Length) %>%
unique()
}
})
output$filter1 <- renderUI({
radioButtons("fil1","", choices=vards1())
})
output$filter2 <- renderUI({
radioButtons("fil2","", choices=vards2())
})
}
The user interface of the Shiny app I'm working on is supposed to work in the following manner:
User finds the desired observation(s) after applying a set of filters.
User clicks "Add" action button, so selected observation(s) are added to a running list/vector/etc of observations to be analyzed.
User modifies filters to find other observations which are to be included as well.
Loop back to step 1 as many times as user desires.
I cannot seem to find a way to save this list of observations to be analyzed. In the example I attached, the "observation ID" is the name of the model of the car (mtcars is used). I also did not include any data analysis, since I do not think that's necessary. In essence, the entire dataset (mtcars) should be filtered using dplyr in a reactive environment to only include the running list of selected observations.
Here's the code:
data("mtcars")
mtcars$model <- rownames(mtcars)
ui <- fluidPage(
titlePanel("sample"),
sidebarLayout(
sidebarPanel(
uiOutput("disp"),
uiOutput("qsec"),
uiOutput("model"),
actionButton("add", "Add"),
uiOutput("selectedModel")
),
mainPanel(
plotOutput("data_analysis")
)
)
)
server <- function(input, output) {
output$disp <- renderUI({
selectInput(
"disp_sel",
"Select disp:",
unique(mtcars$disp),
selected = NULL,
multiple = T,
selectize = T
)
})
output$qsec <- renderUI({
temp = mtcars
if (!is.null(input$disp_sel)){temp = temp %>% filter(disp %in% input$disp_sel)}
selectInput(
"qsec_sel",
"Select qsec:",
unique(temp$qsec),
selected = NULL,
multiple = T,
selectize = T
)
})
output$model <- renderUI({
temp = mtcars
if (!is.null(input$disp_sel)){temp = temp %>% filter(disp %in% input$disp_sel)}
if (!is.null(input$qsec_sel)){temp = temp %>% filter(qsec %in% input$qsec_sel)}
selectInput(
"model_sel",
"Select model:",
unique(temp$model),
selected = NULL,
multiple = T,
selectize = T
)
})
output$selectedModel <- renderUI({
req(input$add)
selectInput(
"list_of_selections",
"Selected models:",
unique(mtcars$model),
selected = NULL, # this should change when "Add" is pressed
multiple = T,
selectize = T
)
})
r_data = eventReactive(input$add,{
mtcars %>% filter(model %in% input$list_of_selections)
})
output$data_analysis <- renderPlot({
# do something with r_data (filtered data)
})
}
# Run the application
shinyApp(ui = ui, server = server)
I've looked into modular code, reactive lists, and other stuff I don't even remember... Any help is greatly appreciated.
Try this
data("mtcars")
mtcars$model <- rownames(mtcars)
df1 <- mtcars
ui <- fluidPage(
titlePanel("sample"),
sidebarLayout(
sidebarPanel(
uiOutput("disp"),
uiOutput("qsec"),
uiOutput("model"),
actionButton("add", "Add"),
uiOutput("selectedModel")
),
mainPanel(
DTOutput("selecteddata"),
plotOutput("data_analysis")
)
)
)
server <- function(input, output) {
output$disp <- renderUI({
selectInput(
"disp_sel",
"Select disp:",
unique(mtcars$disp),
selected = NULL,
multiple = T,
selectize = T
)
})
output$qsec <- renderUI({
temp = mtcars
if (!is.null(input$disp_sel)){temp = temp %>% filter(disp %in% input$disp_sel)}
selectInput(
"qsec_sel",
"Select qsec:",
unique(temp$qsec),
selected = NULL,
multiple = T,
selectize = T
)
})
output$model <- renderUI({
temp = mtcars
if (!is.null(input$disp_sel)){temp = temp %>% filter(disp %in% input$disp_sel)}
if (!is.null(input$qsec_sel)){temp = temp %>% filter(qsec %in% input$qsec_sel)}
selectInput(
"model_sel",
"Select model:",
unique(temp$model),
selected = NULL,
multiple = T,
selectize = T
)
})
selected_data <- eventReactive(input$add,{
df1 %>% filter(model %in% input$model_sel)
})
output$selecteddata <- renderDT(
selected_data(), # reactive data
class = "display nowrap compact", # style
filter = "top", # location of column filters
options = list( # options
scrollX = TRUE # allow user to scroll wide tables horizontally
)
)
output$selectedModel <- renderUI({
req(input$add)
selectInput(
"list_of_selections",
"Selected models:",
choices = unique(selected_data()$model),
selected = unique(selected_data()$model), # this should change when "Add" is pressed
multiple = T,
selectize = T
)
})
r_data = eventReactive(input$add,{
mtcars %>% filter(model %in% input$list_of_selections)
})
output$data_analysis <- renderPlot({
ggplot(data=selected_data(), aes(x=disp, y=qsec)) + geom_point()
# do something with r_data (filtered data)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Found the answer. I included
selected <- reactiveValues(s = NULL)
observeEvent(input$add,{selected$s = c(selected$s, input$model})
into the server part. Then the selected models are stored in selected$s.