In the following app, I would like to add a global button, to save the tables in the 2 panels at the same time.
Ideally, they should be saved to an xlsx file, in tabs named after the corresponding tabs.
Please note that the tabs were created using a module.
Many thanks!!
library(shiny)
library(DT)
modDtUi <- function(id){ # UI module
ns = NS(id)
DT::dataTableOutput(ns('x1'))
}
modDt <- function(input, output, session, data, globalSession){ # Server module
x <- data
output$x1 <- DT::renderDataTable(x, selection = 'none', editable = TRUE)
proxy <- dataTableProxy('x1', session = globalSession)
}
ui <- fluidPage(
mainPanel(
tabsetPanel(
tabPanel("Table1", modDtUi("editable")),
tabPanel("Table2", modDtUi("editable2"))
)
)
)
server <- function(input, output, session) {
callModule(modDt,"editable", data = head(iris,10), globalSession = session)
callModule(modDt,"editable2", data = tail(iris,5), globalSession = session)
}
shinyApp(ui = ui, server = server)
I believe this demo works.
I used reactiveValues v$data to store the data inside the module. The module will return v$data so it can be retrieved when you want to save the data in the shiny server.
I also added an observeEvent to detect changes in the data, and update the data table with replaceData.
The excel file is created using the writexl library, but you could substitute with others of course.
Let me know if this works for you. I imagine there are some elements of this answer that can be improved upon - and if we can identify them, would like to edit further.
library(shiny)
library(DT)
library(writexl)
modDtUi <- function(id){ # UI module
ns = NS(id)
DT::dataTableOutput(ns(id))
}
modDt <- function(input, output, session, data, id, globalSession){ # Server module
v <- reactiveValues(data = data)
output[[id]] <- DT::renderDataTable(v$data, selection = 'none', editable = TRUE)
proxy <- dataTableProxy(id, session = globalSession)
id_input = paste(id, "cell_edit", sep = "_")
# Could add observeEvent here to detect edit event
observeEvent(input[[id_input]], {
info = input[[id_input]]
if (!is.null(info)) {
v$data[info$row, info$col] <<- DT::coerceValue(info$value, v$data[info$row, info$col])
}
replaceData(proxy, v$data, resetPaging = FALSE)
})
return(data = reactive({v$data}))
}
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
width = 2,
actionButton("btn", "Save Both")
),
mainPanel(
tabsetPanel(
tabPanel("Table1", modDtUi("editable1")),
tabPanel("Table2", modDtUi("editable2"))
)
)
)
)
server <- function(input, output, session) {
e1 <- callModule(modDt, "editable1", data = head(iris,10), id = "editable1", globalSession = session)
e2 <- callModule(modDt, "editable2", data = tail(iris,5), id = "editable2", globalSession = session)
observeEvent(input$btn, {
print("Saving...")
sheets <- list("e1" = e1(), "e2" = e2())
write_xlsx(sheets, "test.xlsx")
})
}
shinyApp(ui = ui, server = server)
Related
I am trying to create a editable shiny DT table module. It works well when I pass in iris data.
However, when I tried to pass a reactive value, the module does not work. Does anyone had similar experience before ? Could you share your thought?
library(shiny)
library(DT)
editableUI<-function(id){
ns <- NS(id)
DT::dataTableOutput(ns("mod_table"))
}
editableUIServer<-function(id,data,disable_col,change){
moduleServer(id,
function(input,output,session){
print('hi')
v<-reactiveValues(data = data)
print('here we got v')
print(v$data)
output$mod_table <- renderDT(v$data,
editable = list(target = 'cell',
disable = list(columns=c(disable_col))))
proxy = dataTableProxy('mod_table')
observeEvent(input$mod_table_cell_edit, {
info = input$mod_table_cell_edit
v$data <<- editData(v$data, info)
replaceData(proxy, v$data, resetPaging = FALSE)
})
observeEvent(change(),{
v$data<<-data
})
return(v)
}
)}
# Define UI for application that draws a histogram
ui <- fluidPage(
fluidPage(
fluidRow(pickerInput('spec',label = 'Species',choices = unique(as.character(iris$Species)),selected = "versicolor")
),
fluidRow(editableUI("test")))
)
# Define server logic required to draw a histogram
server <- function(input, output) {
data<-reactive({
iris %>% filter(Species %in% c(input$spec))
})
observe({print(data())})
v<-reactive({editableUIServer("test",data(),c(1), change_ppg = reactive(input$spec))})
}
# Run the application
shinyApp(ui = ui, server = server)
I changed a couple of lines and now it works. Not sure why it was wrong in the first place, though
library(shiny)
library(DT)
editableUI<-function(id){
ns <- NS(id)
DT::dataTableOutput(ns("mod_table"))
}
editableUIServer<-function(id,data,disable_col){
moduleServer(id,
function(input,output,session){
print('hi')
v<-reactiveValues(data = data)
print('here we got v')
output$mod_table <- renderDT(v$data,
editable = list(target = 'cell',
disable = list(columns=c(disable_col))))
proxy = dataTableProxy('mod_table')
observeEvent(input$mod_table_cell_edit, {
info = input$mod_table_cell_edit
v$data <<- editData(v$data, info)
replaceData(proxy, v$data, resetPaging = FALSE)
})
return(v)
}
)}
# Define UI for application that draws a histogram
ui <- fluidPage(
fluidPage(
fluidRow(pickerInput('spec',label = 'Species',choices = unique(as.character(iris$Species)),selected = "versicolor")
),
fluidRow(editableUI("test")))
)
# Define server logic required to draw a histogram
server <- function(input, output) {
data<-reactive({
iris %>% filter(Species %in% c(input$spec))
})
# v<-reactive({editableUIServer("test",data =iris,c(1), change_ppg = reactive(input$spec))})
v<- reactive(editableUIServer("test",data(),c(1)))
observe(print(v()$data))
}
# Run the application
shinyApp(ui = ui, server = server)
I am trying to build an app which; 1) calculates the number of boxes, based on a data.frame, 2) For each box, creates a UI and a corresponding module that will trigger events when the action buttons are clicked, using a subset of that data.frame.
If I am not being explicit enough; the app has n UI's and in each UI, x buttons. I want to loop callModule to create n server functions so when I click on action button in any given UI, I trigger an event specific to that UI.
The problem I am having is that the callModule function apparently does not duplicate itself in a for loop. Instead, I always get only the last id and dataframe (as if the callModule overwrites itself).
I hope I was explicit enough. Here is a MWE:
server.R
library(shinydashboardPlus)
library(shiny)
library(shinydashboard)
source('modules.R')
shinyServer(function(input, output, session) {
# dataframe filtered / updated
dtst <- reactive({
iris[1:input$filter_d, ]
})
# number of items rendered
output$ui <- renderUI({
r <- tagList()
for(k in 1:input$n){
r[[k]] <- u_SimpleTaskView(id = k, d = dtst()[k, ]) # <- grab a subset or column of df
}
r
})
for(y in 1:isolate({input$n})){
callModule(m_UpdateTask, id = y, d = dtst()[, y])
}
})
ui.R
dheader <- dashboardHeaderPlus(title = "s")
dsidebar <- dashboardSidebar(
sidebarMenu(
menuItem("tst", tabName = "tst", icon = icon("bolt"))
)
)
dbody <- dashboardBody(
tabItems(
tabItem(tabName = "tst",
numericInput("n", "number of ui and module pairs", value = 10),
numericInput("filter_d", "RANDOM FILTER", value = 100),
uiOutput("ui")
)
) )
dashboardPagePlus(
title = "s",
header = dheader,
sidebar = dsidebar,
body = dbody
)
modules.R
u_SimpleTaskView <- function(id, d){
ns <- NS(id)
if(length(d) < 5){
# nothing
}else{
renderUI({
tagList(
br(),
HTML(paste0("<strong>Rows: </strong>", "xxxx")),
numericInput("divider", label = "number of rows", value = 2),
br(),
actionButton("go", "go")
)
})
}
}
m_UpdateTask <- function(input, output, session, d){
observeEvent(input$go, {
showModal(
modalDialog(
HTML(paste0("unique: ", length(unique(d))/input$divider ) )
)
)
})
}
Besides not being really minimal (no need for libraries shinydashboardPlus or shinydashboard) there are a couple of issues with your code.
renderUI is a server function not a UI function
If you create controls in the module UI you have to use the namespace function, otherwise you cannot use them in your module server function.
As it is a bit too complicated for me to debug your code directly, let me give you an example from which you can see how to use modules in the way you wanted:
library(shiny)
library(glue)
mod_ui <- function(id, base_df) { ## 3
ns <- NS(id) ## 1
tagList(
helpText(glue("The input parameter 'base_df' has {NROW(base_df)} rows.")),
numericInput(ns("n"), "n:", 2),
textOutput(ns("out"))
)
}
mod <- function(input, output, session) {
get_nr <- reactive(input$n) ## 2
output$out <- renderText(glue("Number selected: {get_nr()}"))
return(list(get_nr = get_nr)) ## 4
}
ui <- fluidPage(
numericInput("n", "number of uis:", 2),
uiOutput("uis"),
textOutput("sum")
)
server <- function(input, output, session) {
handlers <- list()
output$uis <- renderUI({
ret <- lapply(seq.int(input$n),
function(i) mod_ui(glue("mod_{i}"),
data.frame(x = seq.int(i)))) ## 5
tagList(ret)
})
observe(
handlers <<- lapply(seq.int(input$n),
function(i) callModule(mod, glue("mod_{i}"))) ## 6
)
output$sum <- renderText({ ## 7
req(length(handlers) > 0)
m_sum <- sum(sapply(handlers, function(h) h$get_nr()))
glue("Sum of all n: {m_sum}")
})
}
shinyApp(ui, server)
Explanation
In mod_ui we define all the elements one module should have. note the use of ns() for the controls' ids to make use of the namespacing.
In mod (the module server function) we can access controls as we would in the main server function ( i.e. directly liek in input$n.
We can pass arguments to any of the module's functions (like base_df).
If we want to use some of the reactives in the main app, we shoudl return them from the modules server function.
In our main app we use a loop to create the desired number of modules.
We use an observer to store the handlers from the modules in a list
We can access the modules reactives via the handler which we defined earlier.
Update 2021
shiny 1.5.0 introduced an easier interface for modules. The code below uses this "new" interface:
library(shiny)
library(glue)
mod_ui <- function(id, base_df) {
ns <- NS(id)
tagList(
helpText(glue("The input parameter 'base_df' has {NROW(base_df)} rows.")),
numericInput(ns("n"), "n:", 2),
textOutput(ns("out"))
)
}
mod <- function(id) {
moduleServer(id,
function(input, output, session) {
get_nr <- reactive(input$n)
output$out <- renderText(glue("Number selected: {get_nr()}"))
return(list(get_nr = get_nr))
}
)
}
ui <- fluidPage(
numericInput("n", "number of uis:", 2),
uiOutput("uis"),
textOutput("sum")
)
server <- function(input, output, session) {
handlers <- list()
output$uis <- renderUI({
ret <- lapply(seq.int(input$n),
function(i) mod_ui(glue("mod_{i}"),
data.frame(x = seq.int(i))))
tagList(ret)
})
observe({
handlers <<- lapply(seq.int(input$n),
function(i) mod(glue("mod_{i}")))
})
output$sum <- renderText({
req(length(handlers) > 0)
m_sum <- sum(sapply(handlers, function(h) {
res <- h$get_nr()
if(is.null(res)) {
0
} else {
res
}
}))
glue("Sum of all n: {m_sum}")
})
}
shinyApp(ui, server)
I have an R shiny app with a DT datatable that is rendered using the datatable function in order to set various options. I would like to use dataTableProxy and replaceData to update the data in the table, but all the examples I can find assume the DT is rendered directly from the data object, not using the datatable function. The reprex below shows what I would like to do, but replaceData doesn't work in this pattern. How do I do this? Thanks.
# based on
# https://community.rstudio.com/t/reorder-data-table-with-seleceted-rows-first/4254
library(shiny)
library(DT)
ui = fluidPage(
actionButton("button1", "Randomize"),
fluidRow(
column(6,
h4("Works"),
DT::dataTableOutput('table1', width="90%")),
column(6,
h4("Doesn't Work"),
DT::dataTableOutput('table2', width="90%"))
)
)
server = function(input, output, session) {
my <- reactiveValues(data = iris)
output$table1 <- DT::renderDataTable(isolate(my$data))
output$table2 <- DT::renderDataTable({
DT::datatable(isolate(my$data),
options = list(lengthChange=FALSE, ordering=FALSE, searching=FALSE,
columnDefs=list(list(className='dt-center', targets="_all")),
stateSave=TRUE, info=FALSE),
class = "nowrap cell-border hover stripe",
rownames = FALSE,
editable = FALSE
) %>%
DT::formatStyle('Sepal.Width', `text-align`="center")
})
observeEvent(input$button1, {
# calculate new row order
row_order <- sample(1:nrow(my$data))
my$data <- my$data[row_order, ]
proxy1 <- DT::dataTableProxy('table1')
DT::replaceData(proxy1, my$data)
proxy2 <- DT::dataTableProxy('table2')
DT::replaceData(proxy2, my$data)
})
}
shinyApp(ui, server)
Update: Very strangely, removing rownames = FALSE made it all possible. I'm not exactly sure why, but probably rownames might be essential for replacing Data.
# based on
# https://community.rstudio.com/t/reorder-data-table-with-seleceted-rows-first/4254
library(shiny)
library(DT)
ui = fluidPage(
actionButton("button1", "Randomize"),
fluidRow(
column(6,
h4("Works"),
DT::dataTableOutput('table1', width="90%")),
column(6,
h4("Doesn't Work"),
DT::dataTableOutput('table2', width="90%"))
)
)
server = function(input, output, session) {
my <- reactiveValues(data = iris)
output$table1 <- DT::renderDataTable(isolate(my$data))
output$table2 <- DT::renderDataTable({
DT::datatable(isolate(my$data),
options = list(lengthChange=FALSE, ordering=FALSE, searching=FALSE,
columnDefs=list(list(className='dt-center', targets="_all")),
stateSave=TRUE, info=FALSE),
class = "nowrap cell-border hover stripe",
# rownames = FALSE,
editable = FALSE
) %>%
DT::formatStyle('Sepal.Width', `text-align`="center")
})
observeEvent(input$button1, {
# calculate new row order
row_order <- sample(1:nrow(my$data))
my$data <- my$data[row_order, ]
proxy1 <- DT::dataTableProxy('table1')
DT::replaceData(proxy1, my$data)
proxy2 <- DT::dataTableProxy('table2')
DT::replaceData(proxy2, my$data)
})
}
shinyApp(ui, server)
I've have tried lots of combinations of this to no avail and am all out of ideas.
I have a data.table, DT, and a shiny app with two selectInputs both based off of the same shiny module.
The first inputSelect should subset my data.table based on the first column and the second takes the remaining subset and subsets DT further based on the values of the second column.
I am finding it impossible to make the choices for the second selectInput to be the values from the second column after the subset where the 1st selectInput == col1.
I have included example code for the app below. The actual app I am making is more complicated than this. Everything works up until the second selectInput. I am having problems making this second renderUI reactive.
Would very much appreciate some tips in the right direction.
library(data.table)
library(shiny)
myUI <- function(id) {
ns <- NS(id)
fluidRow(
uiOutput(ns('myFinalText'))
)
}
ui <- pageWithSidebar(headerPanel = headerPanel(title = "title"),
sidebarPanel = sidebarPanel(
myUI('menu1')
,
myUI('menu2')
),
mainPanel = mainPanel(actionButton("debug","INSPECT"))
)
set.seed(1)
DT <- data.table(col1 = LETTERS[rep(1:2, each = 3)] ,
col2 = LETTERS[sample(1:4, 6, replace = TRUE)],
num = 1:6,
key = c("col1", "col2"))
myTextFunc <- function(input, output, session, text) {
output$myFinalText <- renderUI({
if(text == "textArg1"){
selectInput(paste0(text,"Val"),"choose",choices = DT[,col1])
}else{
selectInput(paste0(text,"Val"),"choose",choices = DT[col1 == input$textArg1Val,col2])
}
})
}
server <- function(input, output, session) {
callModule(myTextFunc, 'menu1', session = session, 'textArg1')
callModule(myTextFunc, 'menu2', session = session, 'textArg2')
observeEvent(input$debug,
browser()
)
}
shinyApp(ui = ui, server = server)
You can add some reactive data manualy
like
myTextFunc <- function(input, output, session, text,data) {
output$myFinalText <- renderUI({
if(text == "textArg1"){
selectInput(paste0(text,"Val"),"choose",choices = DT[,col1])
}else{
selectInput(paste0(text,"Val"),"choose",choices = DT[col1 == data(),col2])
}
})
}
server <- function(input, output, session) {
reactive_choose=reactive({
input$textArg1Val
})
callModule(myTextFunc, 'menu1', 'textArg1')
callModule(myTextFunc, 'menu2', 'textArg2',reactive_choose)
}
Is it possible to capture the label of an actionButton once it is clicked?
Imagine I have 3 buttons on my ui.R and depending on which one I click I want to perform a different action on the server.R.
One caveat is that the buttons are created dynamically on the server.R with dynamic labels (thus the necessity of capturing the label on click)
Thanks
Something like that ?
library(shiny)
server <- function(input, session, output) {
output$printLabel <- renderPrint({input$btnLabel})
}
ui <- fluidPage(
actionButton("btn1", "Label1",
onclick = "Shiny.setInputValue('btnLabel', this.innerText);"),
actionButton("btn2", "Label2",
onclick = "Shiny.setInputValue('btnLabel', this.innerText);"),
verbatimTextOutput("printLabel")
)
shinyApp(ui = ui, server = server)
1) What button was clicked last by the user?
To answer this you can user observeEvent function and by setting up a a variable using reactiveValues function. Make sure you update your libraries and work in the latest version of R (version 3.1.3) as shiny is dependant on this version. Working on windows you can follow example on how to update here
rm(list = ls())
library(shiny)
ui =fluidPage(
sidebarPanel(
textInput("sample1", "Name1", value = "A"),
textInput("sample2", "Name2", value = "B"),
textInput("sample3", "Name3", value = "C"),
div(style="display:inline-block",uiOutput("my_button1")),
div(style="display:inline-block",uiOutput("my_button2")),
div(style="display:inline-block",uiOutput("my_button3"))),
mainPanel(textOutput("text1"))
)
server = function(input, output, session){
output$my_button1 <- renderUI({actionButton("action1", label = input$sample1)})
output$my_button2 <- renderUI({actionButton("action2", label = input$sample2)})
output$my_button3 <- renderUI({actionButton("action3", label = input$sample3)})
my_clicks <- reactiveValues(data = NULL)
observeEvent(input$action1, {
my_clicks$data <- input$sample1
})
observeEvent(input$action2, {
my_clicks$data <- input$sample2
})
observeEvent(input$action3, {
my_clicks$data <- input$sample3
})
output$text1 <- renderText({
if (is.null(my_clicks$data)) return()
my_clicks$data
})
}
runApp(list(ui = ui, server = server))
2) Save the clicks for further manipulation is below
Here's small example based on the work of jdharrison from Shiny UI: Save the Changes in the Inputs and the shinyStorage package.
rm(list = ls())
#devtools::install_github("johndharrison/shinyStorage")
library(shinyStorage)
library(shiny)
my_clicks <- NULL
ui =fluidPage(
#
addSS(),
sidebarPanel(
textInput("sample_text", "test", value = "0"),
uiOutput("my_button")),
mainPanel(uiOutput("text1"))
)
server = function(input, output, session){
ss <- shinyStore(session = session)
output$my_button <- renderUI({
actionButton("action", label = input$sample_text)
})
observe({
if(!is.null(input$sample_text)){
if(input$sample_text != ""){
ss$set("myVar", input$sample_text)
}
}
})
output$text1 <- renderUI({
input$action
myVar <- ss$get("myVar")
if(is.null(myVar)){
textInput("text1", "You button Name")
}else{
textInput("text1", "You button Name", myVar)
}
})
}
runApp(list(ui = ui, server = server))