How to call a shiny module from a shiny module? - r

How do I call a shiny module from within a shiny module with passing selections from the first module?
As an example I wrote a app to show the Star Wars subjects from dplyr in a DT::data table (module StarWars). The related films from the same data set should be shown in another DT::data table in another sub tab (module Films).
I pass the table selected subject in a reactive value sw_rows_selected_rct from module StarWars to module Films but browser() statement in module Films is not passed.
# Test call of modules inside modules
library(tidyverse)
#' Shiny StarWars module
#'
ui_Films <-
function(id,
title = id,
...,
value = title,
icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
h4("StarWars Films"),
DT::dataTableOutput(outputId = ns("Films")))
}
ui_StarWars <-
function(id,
title = id,
...,
value = title,
icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
DT::dataTableOutput(outputId = ns("StarWars")),
tabsetPanel(ui_Films(
id = ns("Films"), title = "...by Films"
)))
}
ui <- shinyUI(navbarPage(
"Call Modules in Modules test",
ui_StarWars("StarWars", title = "StarWars")
))
Films <-
function(input,
output,
session,
sw_data,
sw_selection) {
ns <- session$ns
sw_films_rct <- observe({
req(sw_data, is.data.frame(sw_selection))
browser() # not reached!!!
sw_films_rct <-
sw_data %>% {
if (is_null(sw_selection))
.
else
filter(., name == sw_selection$name)
}
})
output$StarWarsFilms <- DT::renderDataTable({
req(is.data.frame(sw_films_rct))
DT::datatable(sw_films_rct,
selection = 'single',
options = list(pageLength = 5))
})
}
StarWars <-
function(input, output, session, sw_data) {
sw_rows_selected_rct = reactiveVal()
ns <- session$ns
sw_rows_selected_rct = observeEvent(input$StarWars_rows_selected, {
req(sw_data, input$StarWars_rows_selected != 0)
browser()
sw_data[input$StarWars_rows_selected, ]
})
md_films <- callModule(
module = Films,
id = "Films",
sw_data = sw_data,
sw_selection = sw_rows_selected_rct
)
output$StarWars <- DT::renderDataTable({
req(is.data.frame(sw_data))
DT::datatable(sw_data,
selection = 'single',
options = list(pageLength = 5))
})
}
server <- shinyServer(function(input, output, session) {
sw_data_rct = reactive({
dplyr::starwars %>% mutate(films = NULL,
vehicles = NULL,
starships = NULL)
})
md_StarWars = callModule(module = StarWars,
id = "StarWars",
sw_data = sw_data_rct())
})
# Run the application
shinyApp(ui = ui, server = server)

Your code had a few errors. Remember, observe and observeEvents don't have return values. Set the value of your reactives through the nameofReactive(newValue). Your initial goal is possible if you give the reactive to the module, not the current value of the reactive, so that it can change throughout the course of using the app. In the module, you then have to you the value of the reactive, by using () on the reactive. Oh, and your last output had the wrong name (output$Films should be correct). Here is the working app:
library(tidyverse)
#' Shiny StarWars module
#'
ui_Films <-
function(id, title = id, ..., value = title, icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
h4("StarWars Films"),
DT::dataTableOutput(outputId = ns("Films"))
)
}
ui_StarWars <-
function(id, title = id, ..., value = title, icon = NULL) {
ns <- shiny::NS(id)
tab <- tabPanel(title,
DT::dataTableOutput(outputId = ns("StarWars")),
tabsetPanel(
ui_Films(id = ns("Films"), title = "...by Films"))
)
}
ui <- shinyUI(
navbarPage(
"Call Modules in Modules test",
ui_StarWars("StarWars", title = "StarWars")
)
)
Films <-
function(input, output, session, sw_data, sw_selection) {
ns <- session$ns
sw_films_rct <- reactiveVal()
observe({
sw_films_rct(sw_data() %>% {if(is_null(sw_selection())) . else filter(., name == sw_selection()$name)})
})
output$Films <- DT::renderDataTable({
req(is.data.frame(sw_films_rct()))
DT::datatable(sw_films_rct(),
selection = 'single',
options = list(pageLength = 5))
})
}
StarWars <-
function(input, output, session, sw_data) {
sw_rows_selected_rct= reactiveVal()
ns <- session$ns
observeEvent(input$StarWars_rows_selected, {
req(sw_data(), input$StarWars_rows_selected != 0)
sw_rows_selected_rct(sw_data()[input$StarWars_rows_selected,])
})
md_films <- callModule(module = Films, id = "Films",
sw_data= sw_data,
sw_selection= sw_rows_selected_rct)
output$StarWars <- DT::renderDataTable({
req(is.data.frame(sw_data()))
DT::datatable(sw_data(),
selection = 'single',
options = list(pageLength = 5))
})
}
server <- shinyServer(function(input, output, session) {
sw_data_rct= reactive({dplyr::starwars %>% mutate(films = NULL, vehicles = NULL, starships = NULL)})
md_StarWars= callModule(module = StarWars, id = "StarWars", sw_data = sw_data_rct)
})
# Run the application
shinyApp(ui = ui, server = server)

Related

Updating private but not UI in reactive element

I have an R6 class that I am using to organize my shiny application. Essentially, I want to connect different R6 classes for an experimental interface I am creating and want to reuse my code. As a simplified working example, see the code below.
library(R6)
library(stringi)
library(shiny)
df <- data.frame(dp = c("dp1", "dp2", "dp3"), desc = c("problem 1", "problem 2", "problem 3"))
app <- R6::R6Class(classname = "App",
private = list(
#unique string id
..id = stringi::stri_rand_strings(1, 18),
#the data to be iterated through
..df = df,
#counter to update text
..counter = 1,
#initiating the dp and desc
..dp = 'dp1',
..desc = 'problem 1',
#the underlying server, to be created like a normal server
.server = function(input, output, session){
output$text <- renderText({
private$..desc
})
observeEvent(input$button, {
private$..counter <- private$..counter + 1
self$update_private()
#check the private content since the print is not updating
print(private$..counter)
print(private$..dp)
print(private$..desc)
})
}
),
public = list(
#create names for ui elements
button = NULL,
text = NULL,
initialize = function(){
self$button <- self$get_id("button")
self$text <- self$get_id("text")
self$update_private()
},
#gives ui outputs unique names tied to the user's id
get_id = function(name, ns = NS(NULL)){
ns <- NS(ns(private$..id))
id <- ns(name)
return(id)
},
#automatically updates the private field based on the counter
update_private = function(){
if(private$..counter == 1){
private$..dp <- "dp1"
} else if(private$..counter == 2){
private$..dp <- "dp2"
} else{
private$..dp <- "dp3"
}
private$..desc <- private$..df[private$..df$dp == private$..dp, "desc"]
},
ui = function(){
fluidPage(
h1("An Example"),
mainPanel(
textOutput(self$text)),
sidebarPanel(
shiny::actionButton(inputId = self$button,
label = 'Update!',
width = '100%'
))
)
},#end ui
server = function(input, output, session){
callModule(module = private$.server, id = private$..id)
}
)
)
test <- app$new()
ui <- test$ui()
server <- function(input, output, session) {
test$server()
}
shinyApp(ui = ui, server = server)
What I want: when someone clicks the action button, the reactive ui will update and the desired text from the data frame will be sliced and displayed.
What I am getting: the internal private data fields are updating but the reactive ui elements are not.
Any ideas what could be causing this or a workaround? I thought about externally trying to use the observe event and then reinitiating the class with a new counter number. But I also can't seem to figure out that option either.
Appreciate your help!
For anyone that comes across this problem... I figured out that even though the private is updating, and even though render is technically a reactive environment, you need to have your data stored publically in a reactive field.
library(R6)
library(stringi)
library(shiny)
df <- data.frame(dp = c("dp1", "dp2", "dp3"), desc = c("problem 1", "problem 2", "problem 3"))
app <- R6::R6Class(classname = "App",
private = list(
#unique string id
..id = stringi::stri_rand_strings(1, 18),
#the data to be iterated through
..df = df,
#counter to update text
..counter = 0,
#initiating the dp and desc
..dp = NA,
..desc = NA,
#the underlying server, to be created like a normal server
.server = function(input, output, session){
output$text <- renderText({
self$desc$text
})
observeEvent(input$button, {
private$..counter <- private$..counter + 1
self$update_private()
self$desc$text <- private$..desc
#check the private content since the print is not updating
print(private$..counter)
print(private$..dp)
print(private$..desc)
})
}
),
active = list(
.counter = function(value){
if(missing(value)){
private$..counter
}else{
private$..counter <- value
}
}
),
public = list(
#create names for ui elements
button = NULL,
text = NULL,
#Need this to update the text***************
desc = reactiveValues(text = NA),
initialize = function(counter = self$.counter){
self$.counter <- counter
self$button <- self$get_id("button")
self$text <- self$get_id("text")
self$update_private()
self$desc$text <- private$..desc
},
#gives ui outputs unique names tied to the user's id
get_id = function(name, ns = NS(NULL)){
ns <- NS(ns(private$..id))
id <- ns(name)
return(id)
},
#automatically updates the private field based on the counter
update_private = function(){
if(private$..counter == 1){
private$..dp <- "dp1"
} else if(private$..counter == 2){
private$..dp <- "dp2"
} else{
private$..dp <- "dp3"
}
private$..desc <- private$..df[private$..df$dp == private$..dp, "desc"]
},
ui = function(){
fluidPage(
h1("An Example"),
mainPanel(
textOutput(self$text)),
sidebarPanel(
shiny::actionButton(inputId = self$button,
label = 'Update!',
width = '100%'
))
)
},#end ui
server = function(input, output, session){
counter <- reactiveVal(private$..counter)
callModule(module = private$.server, id = private$..id)
}
)
)
test <- app$new(counter = 1)
ui <- test$ui()
server <- function(input, output, session) {
test$server()
}
shinyApp(ui = ui, server = server)

R Shiny - Saving results of dynamically created modules

I encountered the following problem that I have tried to summarize in this minimal reproducible example.
The app should be able to dynamically create modules and render the UI of the module - obj_UI in my example - in a tab of the tabsetpanel objTP. Each of this modules should render a R6 object of type objR6. I would like to save the resulting R6 objects into a reactiveValues variable called objCollection and display it in the verbatimTextOutput called displayValues.
When clicking on the input$addObject button, I get the error message "Error in <-: cannot add bindings to a locked environment". I believe the problem lies in the observeEvent at the very end of the example, but cannot figure what it is.
Any help would be much appreciated!
library(shiny)
library(R6)
# Simple R6 object
objR6 <- R6::R6Class(
"objR6",
public = list(
identifier = NULL,
selected_value = NULL,
initialize = function(identifier) {
self$identifier <- identifier
}
)
)
# Module Ui
obj_UI <- function(id) {
tagList(
selectInput(NS(id, "value"), "Chose Value", letters)
)
}
# Module Server
obj_Server <- function(id) {
moduleServer(id, function(input, output, session) {
obj <- reactiveVal(objR6$new(id))
observeEvent(input$value, {
newObj <- obj()$clone()
newObj$selectec_value <- input$value
obj(newObj)
})
return(reactive(obj()))
})
}
# Shiny App
ui <- fluidPage(
fluidPage(
selectInput("objSelection", "Select Object",
choices = "",
selectize = FALSE,
size = 10),
actionButton("addObject", "Add Object"),
actionButton("rmvObject", "Remove Object"),
tabsetPanel(id = "objTP"),
verbatimTextOutput("displayValues")
)
)
server <- function(input, output, session) {
objCount <- reactiveVal(0)
objCollection <- reactiveValues(objects = list())
# Reaction on action button "addObject"
observeEvent(input$addObject, {
# Add another item
objCount(objCount() + 1)
newObjName <- paste0("Object_", objCount())
updateSelectInput(session, "objSelection", choices = c(paste0("Object_", 1:objCount())))
# Append the object tabset panel
appendTab("objTP", tabPanel(newObjName, obj_UI(newObjName)), select = TRUE)
})
# Reaction on action button "rmvObject"
observeEvent(input$rmvObject, {
delObjName <- paste0("Object_", objCount())
objCount(objCount() - 1)
updateSelectInput(session, "objSelection", choices = c(paste0("Object_", 1:objCount())))
removeTab("objTP", target = delObjName)
})
# Implement the server side of module
observeEvent(objCount(), {
if (objCount() > 0) {
for (i in 1:objCount()) {
identifier <- paste0("Object_", i)
observeEvent(obj_Server(identifier), {
objCollection$objects[[identifier]] <- obj_Server(identifier)
})
}
}
# Ouput the selected values
output$displayValues <- renderPrint({
reactiveValuesToList(objCollection)
})
})
}
shinyApp(ui, server)
The following minimal reproducible example is an answer to the problem above. In comparison to the code above I corrected a typo in the server function of the module and also put the initialization of the server part in the observeEvent for the input$addObject and removed the observeEvent for objCount().
library(shiny)
library(R6)
# Simple R6 object
objR6 <- R6::R6Class(
"objR6",
public = list(
identifier = NULL,
selected_value = NULL,
initialize = function(identifier) {
self$identifier <- identifier
}
)
)
# Module Ui
obj_UI <- function(id) {
tagList(
selectInput(NS(id, "value"), "Chose Value", letters)
)
}
# Module Server
obj_Server <- function(id) {
moduleServer(id, function(input, output, session) {
obj <- reactiveVal(objR6$new(id))
observeEvent(input$value, {
newObj <- obj()$clone()
newObj$selected_value <- input$value
obj(newObj)
})
return(reactive(obj()))
})
}
# Shiny App
ui <- fluidPage(
fluidPage(
selectInput("objSelection", "Select Object",
choices = "",
selectize = FALSE,
size = 10),
actionButton("addObject", "Add Object"),
actionButton("rmvObject", "Remove Object"),
tabsetPanel(id = "objTP"),
verbatimTextOutput("displayValues")
)
)
server <- function(input, output, session) {
objCount <- reactiveVal(0)
objCollection <- reactiveValues(objects = list())
# Reaction on action button "addObject"
observeEvent(input$addObject, {
# Add another item
objCount(objCount() + 1)
newObjName <- paste0("Object_", objCount())
updateSelectInput(session, "objSelection", choices = c(paste0("Object_", 1:objCount())))
# Append the object tabset panel
appendTab("objTP", tabPanel(newObjName, obj_UI(newObjName)), select = TRUE)
# Add the server component of the module
observeEvent(obj_Server(newObjName), {
objCollection$objects[[newObjName]] <- obj_Server(newObjName)
})
})
# Reaction on action button "rmvObject"
observeEvent(input$rmvObject, {
delObjName <- paste0("Object_", objCount())
if (objCount() > 0) {
objCount(objCount() - 1)
removeTab("objTP", target = delObjName)
objCollection$objects[[delObjName]] <- NULL
if (objCount() > 0) {
updateSelectInput(session, "objSelection", choices = c(paste0("Object_", 1:objCount())))
} else {
updateSelectInput(session, "objSelection", choices = "")
}
}
})
# Ouput the selected values
output$displayValues <- renderPrint({
lapply(reactiveValuesToList(objCollection)$objects, function(i) {i()})
})
}
shinyApp(ui, server)

CheckboxInput with Edit table in DT R Shiny

I tried to combine editing table by adding, deleting row in DT table with checkboxInput(). It is not quite correct.
If I didn't add editing feature, it returned correct, but if I added editing feature,it didn't response after I added another row. I got stuck for a while, I will appreciate any help from you guys
library(shiny)
library(shinyjs)
library(DT)
# Tab 2 UI code.
tab2UI <- function(id) {
ns <- NS(id)
tabPanel(
"Tab 2",
fluidRow(
#uiOutput(ns('cars')),
h2('The mtcars data'),
DT::dataTableOutput(ns('mytable2')),
uiOutput(ns("edit_1")),
h2("Selected"),
tableOutput(ns("checked"))
)
)
}
# Tab 2 server code.
tab2Server <- function(input, output, session) {
ns <- session$ns
# Helper function for making checkboxes.
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(ns(paste0(id, i)), label = NULL, ...))
}
inputs
}
# Update table records with selection.
subsetData <- reactive({
sel <- mtcars[1:5,]
})
values <- reactiveValues(df = NULL)
observe({
values$df <- subsetData()
})
# Datatable with checkboxes.
output$mytable2 <- DT::renderDataTable(
datatable(
data.frame(values$df,Favorite=shinyInput(checkboxInput,nrow(values$df), "cbox_", width = 10)),
editable = TRUE,
selection = 'single',
escape = FALSE,
options = list(
paging = FALSE,
preDrawCallback = JS('function() {Shiny.unbindAll(this.api().table().node()); }'),
drawCallback = JS('function() {Shiny.bindAll(this.api().table().node()); }')
)
)
)
observeEvent(input$add.row_1,{
# print(paste0("Row selected",input$mytable2_rows_selected))
if (!is.null(input$mytable2_rows_selected)) {
td <- values$df
tid_n = as.numeric(input$mytable2_rows_selected)
tid = as.numeric(input$mytable2_rows_selected) + 1
if(tid_n == nrow(td)){
td<- rbind(data.frame(td[1:tid_n, ]),
data.frame(td[tid_n, ]))
}else{
td<- rbind(data.frame(td[1:tid_n, ]),
data.frame(td[tid_n, ]),
data.frame(td[tid: nrow(td), ]))
}
td <- data.frame(td)
print(td)
values$df <- td
}
})
output$edit_1 <- renderUI({
tagList(
actionButton(inputId = ns("add.row_1"), label = "Add Row", icon = icon("plus"),class = "example-css-selector",style = "background-color:gray; border-color:gray;color:white;height:31px;"),
actionButton(inputId = ns("delete.row_1"), label = "Delete Row", icon = icon("minus"),class = "example-css-selector",style = "background-color:gray; border-color:gray;color:white;height:31px;"),br(),br()
)
})
# Helper function for reading checkbox.
shinyValue = function(id, len) {
values <- unlist(lapply(seq_len(len), function(i) {
value = input[[paste0(id, i)]]
if (is.null(value)) NA else value
}))
return(values)
}
# Output read checkboxes.
observe({
len <- nrow(values$df)
output$checked <- renderTable({
data.frame(selected=shinyValue("cbox_", len))
})
})
}
# Define UI for application.
ui <- fluidPage(
useShinyjs(),
navbarPage(
'Title',
tab2UI("tab2")
)
)
# Define server.
server <- function(input, output, session) {
# Call tab2 server code.
callModule(tab2Server, "tab2")
}
# Run the application
shinyApp(ui = ui, server = server)

Make a Shiny module reactive when creating the module via a function

I'm trying to generalise Shiny modules so different functions can be passed through, but the expected behaviour of reactivity is not working - could someone point me in the right direction? I have a reprex below that illustrates my problem.
I expect that the dynamic selection of view_id to change values in the renderShiny() function. It works on app load but changing selections do not flow through.
Is it something to do with the environment the module function is created within?
library(shiny)
create_shiny_module_funcs <- function(data_f,
model_f,
outputShiny,
renderShiny){
server_func <- function(input, output, session, view_id, ...){
gadata <- shiny::reactive({
# BUG: this view_id is not reactive but I want it to be
data_f(view_id(), ...)
})
model_output <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- renderShiny({
shiny::validate(shiny::need(model_output(),
message = "Waiting for model output"))
message("Rendering model output")
model_output()
}, ...)
return(model_output)
}
ui_func <- function(id, ...){
ns <- shiny::NS(id)
outputShiny(outputId = ns("ui_out"), ...)
}
list(
shiny_module = list(
server = server_func,
ui = ui_func
)
)
}
# create the shiny module
ff <- create_shiny_module_funcs(
data_f = function(view_id) mtcars[, view_id],
model_f = function(x) mean(x),
outputShiny = shiny::textOutput,
renderShiny = function(x) shiny::renderText(paste("Mean is: ", x))
)
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
ff$shiny_module$ui("demo1"),
br()
)
## server.R
server <- function(input, output, session){
view_id <- reactive({
req(input$select)
input$select
})
callModule(ff$shiny_module$server, "demo1", view_id = view_id)
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
The problem was the renderShiny function needs to wrap another function that creates the actual output, so its actually two separate capabilities confused by me as one: renderShiny should take the output of another function that actually creates the thing to render. The below then works:
library(shiny)
module_factory <- function(data_f = function(x) mtcars[, x],
model_f = function(x) mean(x),
output_shiny = shiny::plotOutput,
render_shiny = shiny::renderPlot,
render_shiny_input = function(x) plot(x),
...){
ui <- function(id, ...){
ns <- NS(id)
output_shiny(ns("ui_out"), ...)
}
server <- function(input, output, session, view_id){
gadata <- shiny::reactive({
data_f(view_id(), ...)
})
model <- shiny::reactive({
shiny::validate(shiny::need(gadata(),
message = "Waiting for data"))
model_f(gadata(), ...)
})
output$ui_out <- render_shiny({
shiny::validate(shiny::need(model(),
message = "Waiting for model output"))
render_shiny_input(gadata())
})
return(model)
}
list(
module = list(
ui = ui,
server = server
)
)
}
made_module <- module_factory()
## ui.R
ui <- fluidPage(title = "module bug Shiny Demo",
h1("Debugging"),
selectInput("select", label = "Select", choices = c("mpg","cyl","disp")),
textOutput("view_id"),
made_module$module$ui("factory1"),
br()
)
## server.R
server <- function(input, output, session){
callModule(made_module$module$server, "factory1", view_id = reactive(input$select))
output$view_id <- renderText(paste("Selected: ", input$select))
}
# run the app
shinyApp(ui, server)
I think you want something like this.
library(shiny)
library(plyr)
library(dplyr)
library(DT)
library(data.table)
ui <- pageWithSidebar(
headerPanel = headerPanel('data'),
sidebarPanel = sidebarPanel(fileInput(
'mtcars', h4('Uplaodmtcardata in csv format')
),
uiOutput('tabnamesui')),
mainPanel(uiOutput("tabsets"))
)
server <- function(input, output, session) {
mtcarsFile <- reactive({
input$mtcars
})
xxmtcars <-
reactive({
read.table(
file = mtcarsFile()$datapath,
sep = ',',
header = T,
stringsAsFactors = T
)
})
tabsnames <- reactive({
names(xxmtcars())
})
output$tabnamesui <- renderUI({
req(mtcarsFile())
selectInput(
'tabnamesui',
h5('Tab names'),
choices = as.list(tabsnames()),
multiple = T
# selected = SalesGlobalDataFilter1Val()
)
})
tabnamesinput <- reactive({
input$tabnamesui
})
output$tabsets <- renderUI({
req(mtcarsFile())
tabs <-
reactive({
lapply(tabnamesinput(), function(x)
tabPanel(title = basename(x)
,fluidRow(splitLayout(cellWidths = c("50%", "50%"),
plotOutput(paste0('plot1',x)),
plotOutput(paste0('plot2',x)
))),fluidRow(splitLayout(cellWidths =
c("50%", "50%"),
plotOutput(paste0('plot3',x)),
plotOutput(paste0('plot4',x)
))),
dataTableOutput(paste0('table',x))))
})
do.call(tabsetPanel, c(tabs()))
})
# Save your sub data here
subsetdata<-reactive({
list_of_subdata<-lapply(tabnamesinput(), function(x) {
as.data.table((select(xxmtcars(),x)))
})
names(list_of_subdata)<-tabnamesinput()
return(list_of_subdata)
})
observe(
lapply(tabnamesinput(), function(x) {
output[[paste0('table',x)]] <-
renderDataTable({
subsetdata()[[x]]
})}))
observe(
lapply(tabnamesinput(), function(x) {
for(i in paste0("plot",1:4)){
output[[paste0(i,x)]] <-
renderPlot({subsetdata()[[x]]%>%plot()#CODE REPEATED
})
}
})
)
}
runApp(list(ui = ui, server = server))
Data Source:
https://gist.githubusercontent.com/seankross/a412dfbd88b3db70b74b/raw/5f23f993cd87c283ce766e7ac6b329ee7cc2e1d1/mtcars.csv

Plugging edited Datatable values in a shiny app

I am trying to understand how to use the values from an edited data table and do some calculation.
I have a data frame which loads by default. When you click on 'run' it updates the tables based on the input value.
I want the user to edit the values manually in the table and then click on 'run'. Next, I want the app to take the edited values in the data table, run some calculations, and update the table. In this way the user can dynamically see the result their input makes on the table.
library(shiny)
library(DT)
library(dplyr)
#### Module 1 renders the first table
tableMod <- function(input, output, session, modelRun,modelData,budget){
output$x1 <- DT::renderDataTable({
modelRun()
isolate(
datatable(
modelData %>%
mutate(New_Membership = as.numeric(Modified * 0.01)*(budget())),
selection = 'none', editable = TRUE
)
)
})
observeEvent(input$x1_cell_edit, {
df[input$x1_cell_edit$row,input$x1_cell_edit$col] <<- input$x1_cell_edit$value
})
}
tableUI <- function(id) {
ns <- NS(id)
dataTableOutput(ns("x1"))
}
ui <- function(request) {
fluidPage(
tableUI("opfun"),
numericInput("budget_input", "Total Forecast", value = 2),
actionButton("opt_run", "Run")
)
}
server <- function(input, output, session) {
df <- data.frame(Channel = c("A", "B","C"),
Current = c(2000, 3000, 4000),
Modified = c(2500, 3500,3000),
New_Membership = c(450, 650,700),
stringsAsFactors = FALSE)
callModule( tableMod,"opfun",
modelRun = reactive(input$opt_run),
modelData = df,
budget = reactive(input$budget_input))
observeEvent(input$opt_run, {
cat('HJE')
})
}
shinyApp(ui, server, enableBookmarking = "url")
A clean solution (rather than assigning values in other environments) would be to use a reactiveVal in your module which is in sync with the datatable. You can return this reactive from your module to make use of it also in the main application:
library(shiny)
library(DT)
library(dplyr)
#### Module 1 renders the first table
tableMod <- function(input, output, session, modelRun, modelData, budget){
df <- reactiveVal(modelData) ## this variable will be in sync with your datatable
output$x1 <- DT::renderDataTable({
modelRun()
isolate(
datatable(
df() %>% ## ...you always use the synced version here
mutate(New_Membership = as.numeric(Modified * 0.01)*(budget())),
selection = 'none', editable = TRUE
)
)
})
observeEvent(input$x1_cell_edit, {
new_df <- df()
row <- input$x1_cell_edit$row
col <- input$x1_cell_edit$col
value <- as.numeric(input$x1_cell_edit$value)
new_df[row, col] <- value
df(new_df) ## ...and you make sure that 'df' stays in sync
})
list(updated_df = df) ## ...finally you return it to make use of it in the main app too
}
tableUI <- function(id) {
ns <- NS(id)
dataTableOutput(ns("x1"))
}
ui <- function(request) {
fluidPage(
tableUI("opfun"),
numericInput("budget_input", "Total Forecast", value = 2),
actionButton("opt_run", "Run")
)
}
server <- function(input, output, session) {
df <- data.frame(Channel = c("A", "B","C"),
Current = c(2000, 3000, 4000),
Modified = c(2500, 3500,3000),
New_Membership = c(450, 650,700),
stringsAsFactors = FALSE)
result <- callModule( tableMod,"opfun",
modelRun = reactive(input$opt_run),
modelData = df,
budget = reactive(input$budget_input))
observeEvent(input$opt_run, {
str(result$updated_df())
})
}
shinyApp(ui, server, enableBookmarking = "url")
This should work, but not the "cleanest" implementation:
I had to take df out of shiny to make your code work. Used assign to replace df in global environment (not the best idea...) once datatable is edited. But, data is not recalculated untill Run is pressed. Once Run is pressed modelData is overwritten: (modelData <- df). Again not the best idea, probably making modelData reactive will be better idea.
Also, have a look at DT::replaceData. It might be better idea than regenerating full table.
library(shiny)
library(DT)
library(dplyr)
df <- data.frame(Channel = c("A", "B","C"),
Current = c(2000, 3000, 4000),
Modified = c(2500, 3500,3000),
New_Membership = c(450, 650,700),
stringsAsFactors = FALSE)
#### Module 1 renders the first table
tableMod <- function(input, output, session, modelRun,modelData,budget){
observeEvent( input$x1_cell_edit, {
cat ('input$x1_cell_edit \n')
info = input$x1_cell_edit
str(info)
i = info$row
j = info$col
v = info$value
df[i, j] <- DT:::coerceValue(v, df[i, j])
assign("df", df, envir = .GlobalEnv)
})
output$x1 <- DT::renderDataTable({
modelRun()
modelData <- df
isolate(
datatable(
modelData %>%
mutate(New_Membership = as.numeric(Modified * 0.01)*(budget())),
selection = 'none', editable = TRUE
)
)
})
}
tableUI <- function(id) {
ns <- NS(id)
dataTableOutput(ns("x1"))
}
ui <- function(request) {
fluidPage(
tableUI("opfun"),
numericInput("budget_input", "Total Forecast", value = 2),
actionButton("opt_run", "Run")
)
}
server <- function(input, output, session) {
callModule( tableMod,"opfun",
modelRun = reactive(input$opt_run),
modelData = df,
budget = reactive(input$budget_input))
observeEvent(input$opt_run, {
cat('HJE')
})
}
shinyApp(ui, server, enableBookmarking = "url")

Resources