I want to make my rhandsontable read only on clicking the action button 'Freeze Forecast' and activate the table on clicking on 'Edit Forecast'. It should show me the Sum Output on clicking on 'Generate Forecast' button.
Please help to correct my existing code as per above conditions.
UI.R
packages <- c( "shiny", "data.table", "devtools", "shinysky","googleVis","scales","rhandsontable" )
lapply( packages, require, character.only = TRUE )
jsResetCode <- "shinyjs.reset = function() {history.go(0)}" #JS Code to refresh the App
did_recalc <- FALSE
ui <- fluidPage(
# Application title
titlePanel("Scenario Planner Test App"),
br(),br(),
actionButton("recalc", "Generate Forecast"),
actionButton("edit", "Edit Forecast"),
actionButton("freeze", "Freeze Forecast"),br(),br(),
rHandsontableOutput('table'),br(),br(),
textOutput('restitle'),
textOutput('result')
)
Server.R
Sys.setenv(R_ZIPCMD="/usr/bin/zip")
packages <- c( "shiny", "data.table", "devtools", "shinysky","googleVis","scales","reshape2" )
lapply( packages, require, character.only = TRUE )
disableActionButton <- function(id,session) {
session$sendCustomMessage(type="jsCode1",
list(code= paste("$('#",id,"').prop('disabled',true)"
,sep="")))
}
enableActionButton <- function(id,session) {
session$sendCustomMessage(type="jsCode2",
list(code= paste("$('#",id,"').prop('disabled',false)"
,sep="")))
}
shiny::shinyServer( function(input,output,session)({
values <- reactiveValues(data=as.data.frame(runif(2)))
observe({
input$recalc
values$data <- as.data.frame(runif(2))
})
observe({
if(!is.null(input$table))
values$data <- hot_to_r(input$table)
})
output$table <- renderRHandsontable({
rhandsontable(values$data)
})
observe({
input$freeze
print("freeze")
##if(!is.null(input$table))
print("2freeze")
rhandsontable(values$data) %>%
hot_table(readOnly = TRUE)
})
output$restitle <- renderText({
"Sum Output"
})
output$result <- renderText({
sum(values$data)
})
})
)
I got this to work by
Adding a state variable to your reactive called readonly
Adding two observerEvent routines to the edit and freeze action buttions to toggle readonly.
Modifying your output$table command to use the reactive readonly variable.
It would have been easier, and not needed a lot of those elements if you had just used a checkbox to indicate that the table is editable, and then wired that variable to the readOnly parameter, but sometimes you need to do it this way, so I solved it like this.
The complete server.R code is here:
packages <- c("shiny","data.table","devtools","shinysky","googleVis","scales","reshape2")
lapply(packages,require,character.only = TRUE)
disableActionButton <- function(id,session) {
session$sendCustomMessage(type = "jsCode1",
list(code = paste("$('#",id,"').prop('disabled',true)"
,sep = "")))
}
enableActionButton <- function(id,session) {
session$sendCustomMessage(type = "jsCode2",
list(code = paste("$('#",id,"').prop('disabled',false)"
,sep = "")))
}
shiny::shinyServer(function(input,output,session)({
values <- reactiveValues(data = as.data.frame(runif(2)),readonly=FALSE)
observe({
input$recalc
values$data <- as.data.frame(runif(2))
})
observe({
if (!is.null(input$table))
values$data <- hot_to_r(input$table)
})
output$table <- renderRHandsontable({
rhandsontable(values$data,readOnly=values$readonly)
})
observeEvent(input$edit, {
values$readonly <- FALSE
})
observeEvent(input$freeze,{
values$readonly <- TRUE
})
output$restitle <- renderText({
"Sum Output"
})
output$result <- renderText({
sum(values$data)
})
})
)
and it looks like this:
Related
In the below code for a Shiny app, I am expecting the print line to execute when the user clicks on a new row in the datatable. When I do this, the textOutput updates with the selected row via input$table_rows_selected as expected. But why does change <- reactive({ }) not take a dependency on changes to input$table_rows_selected and trigger the print message?
I see that it works with observe({}) but ultimately I want to use a value that reactive returns in different places (e.g here return and return2).
library(shiny)
library(DT)
ui <- fluidPage(
DT::DTOutput("table"),
textOutput("selected"),
textOutput("return"),
textOutput("return2")
)
server <- function(input, output) {
output$table <- DT::renderDataTable({
data.frame(a = 1:3, b = 4:6)
}, selection = 'single')
output$selected <- renderText({
input$table_rows_selected
})
change <- reactive({
input$table_rows_selected
print("it changed!")
"return"
})
output$return <- renderText({
isolate(change())
})
output$return2 <- renderText({
paste0(isolate(change()), "_2")
})
}
# Run the application
shinyApp(ui = ui, server = server)
Your code has 2 problems:
a reactive is just a function, therefore its return value is the last value generated in the reactive -> you need to put input$table_rows_selected last
the isolate(change()) means that reactives don't have a dependency on input$table_rows_selected -> remove the isolate
library(shiny)
library(DT)
ui <- fluidPage(
DT::DTOutput("table"),
textOutput("selected"),
textOutput("return"),
textOutput("return2")
)
server <- function(input, output) {
output$table <- DT::renderDataTable({
data.frame(a = 1:3, b = 4:6)
}, selection = 'single')
output$selected <- renderText({
input$table_rows_selected
})
change <- reactive({
print("it changed!")
input$table_rows_selected
})
output$return <- renderText({
change()
})
output$return2 <- renderText({
paste0(change(), "_2")
})
}
# Run the application
shinyApp(ui = ui, server = server)
I am building a Shiny app and using the code from this question as an example: How to download editable data table in shiny. However, in my code the df <- reactiveVal(dat) does not work, because the dat itself is already a reactive value that comes from an eventReactive({}) function. This is the code I am working with, it works if I define the dat outside of the server, but not when it is created inside the server function of shiny. How do I make a copy of it so that I can show it in a new table (and potentially process further and download in later steps in the app)?
library(shiny)
library(DT)
library(shinyWidgets)
# if the data frame is just an object, it works
#dat <- iris[1:3, ]
ui <- fluidPage( actionBttn(
inputId = "btnProcess",
label = "Process",
size = "sm",
color = "success"
),
DTOutput("my_table"),
DTOutput("table2")
)
server <- function(input, output){
# if the dataframe is a reactive variable, this doesnt work.
dat <- eventReactive(input$btnProcess, {
iris[1:3, ]
})
output[["my_table"]] <- renderDT({
datatable(dat(), editable = "cell")
})
#############################
#### none of these work #####
#############################
#df <- reactiveVal(dat)
#df <- reactiveVal(dat())
#df <- dat()
#df <- dat
observeEvent(input[["my_table_cell_edit"]], {
cell <- input[["my_table_cell_edit"]]
newdf <- df()
newdf[cell$row, cell$col] <- cell$value
df(newdf)
})
output[["table2"]] <- renderDT({
datatable(df())
})
}
shinyApp(ui, server)
Try this
ui <- fluidPage( actionBttn(
inputId = "btnProcess",
label = "Process",
size = "sm",
color = "success"
),
actionBttn(inputId = "reset", label = "Reset", size="sm", color="warning"),
DTOutput("mytable"),
DTOutput("table2")
)
server <- function(input, output){
# if the dataframe is a reactive variable, this doesnt work.
dat <- eventReactive(input$btnProcess, {
iris[1:3, ]
})
mydf <- reactiveValues(data=NULL)
observe({
mydf$data <- dat()
})
output$mytable <- renderDT({
datatable(mydf$data, editable = "cell")
})
observeEvent(input$mytable_cell_edit, {
info = input$mytable_cell_edit
str(info)
i = info$row
j = info$col
v = info$value
mydf$data[i, j] <<- DT::coerceValue(v, mydf$data[i, j])
})
output[["table2"]] <- renderDT({
datatable(mydf$data)
})
observeEvent(input$reset, {
mydf$data <- dat() ## reset it to original data
})
}
shinyApp(ui, server)
I have created a large number of data tables using mapply, however, I need to access the data tables in a following step. R assigns random IDs to these tables if the user does not specify the IDs. Here is an example of what I would like to do:
library(shiny)
ui <- fluidPage(
h2("Last clicked:"),
verbatimTextOutput("last_clicked"),
actionButton("reset", "Reset clicked value"),
h2("Datatable:"),
DT::dataTableOutput("dt")
)
server <- function(input, output) {
# the last clicke value
output$last_clicked <- renderPrint({
str(last())
})
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2), elementId = "DT_Test")
})
observeEvent(input$dt_cell_clicked, {
validate(need(length(input$dt_cell_clicked) > 0, ''))
print("You clicked something!")
})
myProxy = DT::dataTableProxy('dt')
last = reactiveVal(NULL)
observe({
last(input$dt_cell_clicked)
})
observeEvent(input$reset, {
DT::selectRows(myProxy, NULL)
last(NULL)
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2))
})
})
}
shinyApp(ui, server)
If I look at the html, the elementID did not change to what I wanted, in fact, R gives the warning:
Warning in origRenderFunc() :
Ignoring explicitly provided widget ID "DT_Test"; Shiny doesn't use them
Even after the call, still not sure what you are trying to do.
But if you have a list of datatables and you want to access them, it works rather well like this:
library(shiny)
library(purrr)
ui <- fluidPage(
h2("Last clicked:"),
verbatimTextOutput("last_clicked"),
h2("elementId values"),
verbatimTextOutput("elementId_values"),
actionButton("reset", "Reset clicked value"),
h2("Datatable:"),
DT::dataTableOutput("dt")
)
server <- function(input, output) {
# the last clicke value
output$last_clicked <- renderPrint({
str(last())
})
table <- DT::datatable(head(mtcars, 2), elementId = "DT_Test")
table2 <- DT::datatable(tail(mtcars, 1), elementId = "DT_Test2")
list_of_data_tables <- list(table, table2)
element_ids <- purrr::map(list_of_data_tables, "elementId")
output$elementId_values <- renderPrint({
element_ids
})
output$dt <- DT::renderDataTable({
list_of_data_tables[[which(element_ids == "DT_Test2")]]
})
observeEvent(input$dt_cell_clicked, {
validate(need(length(input$dt_cell_clicked) > 0, ''))
print("You clicked something!")
})
myProxy = DT::dataTableProxy('dt')
last = reactiveVal(NULL)
observe({
last(input$dt_cell_clicked)
})
observeEvent(input$reset, {
DT::selectRows(myProxy, NULL)
last(NULL)
output$dt <- DT::renderDataTable({
DT::datatable(head(mtcars, 2))
})
})
}
shinyApp(ui, server)
I encountered an unexpected behavior. What I intend to do is:
- when users click "Select All," all rows in "Summary Table" get selected. This WORKS. However, the code below doesn't get called.
data <- eventReactive(input$selectAll,{
print("Select All - restore data")
rawdata
})
- on the other hand, when users click "Deselect All," all rows in "Summary Table" get deselected. This WORKS and the code below GETS called.
# Restore data when users click 'Deselect All'
data <- eventReactive(input$deselectAll,{
print("Deselect All - restore data")
rawdata
})
Any idea why?
Here is my full code:
DATASET
colA <- c('A','B','C','D','E')
colB <- c(1,2,3,4,5)
rawdata <- as.data.frame(cbind(colA,colB))
View(rawdata)
server.R
function(input, output, session) {
# Activate tab 'Result' when users click 'Run'
observeEvent(input$runButton, {
updateTabsetPanel(session, "allResults", 'result')
})
# Create a dataset based on users' selected variables
data <- eventReactive(input$inputVars_rows_selected,{
print("Select Some Vars")
rawdata[, c(input$inputVars_rows_selected)]
})
# Restore data when users click 'Select All'
data <- eventReactive(input$selectAll,{
print("Select All - restore data")
rawdata
})
# Restore data when users click 'Deselect All'
data <- eventReactive(input$deselectAll,{
print("Deselect All - restore data")
rawdata
})
### VARIABLE SELECTION ####
var <- reactiveValues()
# Select all vars
observeEvent(input$selectAll,{
print("SelectAll ObserveEvent")
var$selected <- 1:nrow(rawdata)
print(var$selected)
})
# Deselect all vars
observeEvent(input$deselectAll,{
print("deselectAll ObserveEvent")
var$selected <- 0
print(var$selected)
print(data())
})
### RESULT TAB ###
result <- eventReactive (input$runButton, {
head(data(),2)
})
### RENDERING FUNCTIONS ###
# Default SummaryTable
output$inputVars <- DT::renderDataTable({
if (input$selectAll==0 & input$deselectAll==0) {
print("Default Summary Table")
DT::datatable(rawdata, options = list(paging = FALSE, searching = FALSE))
}
else {
DT::datatable(rawdata, options = list(paging = FALSE, searching = FALSE), selection = list(target = 'row', selected = var$selected))
}
})
# Display results
output$result <- DT::renderDataTable({
DT::datatable(result(), options = list(paging = FALSE, searching = FALSE))
})
output$temp <- renderPrint({
print(input$selectAll)
print(input$deselectAll)
})
}
ui.R
fluidPage(
sidebarPanel(
actionButton("runButton", strong("Run!"))
),
mainPanel(
tabsetPanel(id = "allResults",
tabPanel(value='inputVars',title='Variable Selection',
verticalLayout(
DT::dataTableOutput('inputVars'),
br(),
fluidRow(align="bottom",
column(2, actionButton("selectAll" , strong("Select All"))),
column(3, actionButton("deselectAll", strong("Deselect All")))
)
)
),
tabPanel(value='result',title='Result', DT::dataTableOutput('result')),
tabPanel(value='temp',title="TEMP", verbatimTextOutput("temp"))
)
)
)
UPDATED Server.R #2:
#Mike and #HubertL, I think you are right: the issue is caused by eventReactive having cached values. In this updated version, observeEvent corresponding to Select All and Deselect All work as expected. However, now eventReactive corresponding to input$inputVars_rows_selected NEVER gets called. Any idea why?
function(input, output, session) {
# Activate tab 'Result' when users click 'Run'
observeEvent(input$runButton, {
updateTabsetPanel(session, "allResults", 'result')
})
data <- reactiveValues()
# Create a dataset based on users' selected variables
data <- eventReactive(input$inputVars_rows_selected,{
print("Select Some Vars")
print(input$inputVars_rows_selected)
rawdata[, c(input$inputVars_rows_selected)]
})
### VARIABLE SELECTION ####
var <- reactiveValues()
# Select all vars
observeEvent(input$selectAll,{
print("SelectAll ObserveEvent")
data <- rawdata
var$selected <- 1:nrow(rawdata)
print(var$selected)
print(data)
})
# Deselect all vars
observeEvent(input$deselectAll,{
print("deselectAll ObserveEvent")
data <- rawdata
var$selected <- 0
print(var$selected)
print(data)
})
### RESULT TAB ###
result <- eventReactive (input$runButton, {
head(data(),2)
})
### RENDERING FUNCTIONS ###
# Default SummaryTable
output$inputVars <- DT::renderDataTable({
if (input$selectAll==0 & input$deselectAll==0) {
print("Default Summary Table")
DT::datatable(rawdata, options = list(paging = FALSE, searching = FALSE))
}
else {
DT::datatable(rawdata, options = list(paging = FALSE, searching = FALSE), selection = list(target = 'row', selected = var$selected))
}
})
# Display results
output$result <- DT::renderDataTable({
DT::datatable(result(), options = list(paging = FALSE, searching = FALSE))
})
output$temp <- renderPrint({
print(input$selectAll)
print(input$deselectAll)
print(input$inputVars_rows_selected)
})
}
One reason is because eventReactive is "lazily-evaluated" as opposed to observeEvent which is evaulated immediately.
So in your case the observeEvent corresponding to deselectAll actually uses data(), so that reactiveEvent gets triggered.
# Deselect all vars
observeEvent(input$deselectAll,{
print("deselectAll ObserveEvent")
var$selected <- 0
print(var$selected)
print(data())
})
But the observeEvent corresponding to selectAll does not use data(), so that reactiveEvent does not get triggered:
# Select all vars
observeEvent(input$selectAll,{
print("SelectAll ObserveEvent")
var$selected <- 1:nrow(rawdata)
print(var$selected)
})
I suggest the following changes
If you add a print(data()) here you get some of the behavior you
are seeking.
But it is still not completely right because HubertL's comment that
one definition of data is being overwritten is also valid - and
note that it is not easy to tell where it the data is being pulled.
This is because eventReactive have cached values, so your print
may not show up if a cached value is being used - your code need be
executed to pull that data().
So in any case I would certainly suggest using different names (and
more descriptive) than just repeating "data" to avoid confusion.
Also there is no need to use an eventReactive here, you probably
want a simple reactive. eventReactive is usually needed if you
want to avoid "reactions" from all the other reactive variables in
the code, and I don't see a need for that here.
I would also recommend putting rawdata into a reactiveValues something like this: rv <- reactiveValues(rawdata=rawdata) and then using it as rv$rawdata. This makes it reactive, and then something that uses it will be triggred and recomputed if it ever changes.
See this link (observeEvent vs. eventReactive) for a discussion of the "laziness" of those commands.
Below is the code that works. #Mike and #HubertL were right. The reason is because reactive is lazy vs observeEvent is not. Thanks all for your help!
function(input, output, session) {
# Activate tab 'Result' when users click 'Run'
observeEvent(input$runButton, {
updateTabsetPanel(session, "allResults", 'result')
})
data <- reactive({
print("Select Some Vars")
print(input$inputVars_rows_selected)
rawdata[input$inputVars_rows_selected,]
})
### VARIABLE SELECTION ####
var <- reactiveValues()
# Select all vars
observeEvent(input$selectAll,{
print("SelectAll --- ObserveEvent")
var$selected <- 1:nrow(rawdata)
print(var$selected)
print(input$inputVars_rows_selected)
})
# Deselect all vars
observeEvent(input$deselectAll,{
print("deselectAll --- ObserveEvent")
var$selected <- 0
print(var$selected)
})
### RESULT TAB ###
result <- eventReactive (input$runButton, {
head(data(),5)
})
### RENDERING FUNCTIONS ###
# Default SummaryTable
output$inputVars <- DT::renderDataTable({
if (input$selectAll==0 & input$deselectAll==0) {
print("Default Summary Table")
DT::datatable(rawdata, options = list(paging = FALSE, searching = FALSE))
}
else {
DT::datatable(rawdata, options = list(paging = FALSE, searching = FALSE), selection = list(target = 'row', selected = var$selected))
}
})
# Display results
output$result <- DT::renderDataTable({
DT::datatable(result(), options = list(paging = FALSE, searching = FALSE))
})
output$temp <- renderPrint({
print(input$selectAll)
print(input$deselectAll)
print(input$inputVars_rows_selected)
})
}
I'd like to load a table from a file, make some computations (ie. sum elements of two columns) when I click a button and show the results into a datatable. Easy. However, every time I load a new file, I'd like to clean the previous results and not show them, otherwise, it is confusing whether they are the results of the new or the old ones.
Here's what I tried. but I didn't succeeed on it...
example table: tab.csv
x;A;B
x1;1;0
x2;2;1
x3;1;1
x4;5;2
x5;3;3
code: ui.R
shinyUI(pageWithSidebar(
headerPanel(""),
sidebarPanel(),
mainPanel(fluidRow(
fileInput("table", "Choose CSV File"),
actionButton("BUTCS", "Compute sum"),
dataTableOutput("tablesum")
))
))
server.R
shinyServer(function(input, output) {
user <- new.env()
user$table <- NULL
user$tablesum <- NULL
observe({
if(is.null(input$table)){return()}
tablefilecsv <- input$table
user$table <- read.csv2(tablefilecsv$name, header = TRUE)
})
observeEvent(input$table, {
if(is.null(input$table)){return()}
user$tablesum <- NULL
})
output$tablesum <- renderDataTable(
{
if(is.null(input$BUTCS)){return()}
d <- user$table
user$tablesum <- data.frame(x=d$x, sum=(d$A+d$B))
}, options = list(paging = FALSE,searching = FALSE))
})
Try, i think it is what you want
shinyServer(function(input, output) {
user <- reactiveValues(table= NULL, tablesum= NULL)
observeEvent(input$table, {
if(is.null(input$table)){
return()
}else{
tablefilecsv <- input$table
user$table <- read.csv2(tablefilecsv$datapath ,header = TRUE)
output$tablesum <- renderDataTable(NULL)
}
})
observeEvent(input$BUTCS,{
output$tablesum <- renderDataTable({
d <- user$table
user$tablesum <- data.frame(x=d$x, sum=(d$A+d$B))
}, options = list(paging = FALSE,searching = FALSE))
})
})
Option using reactive functional ( added by #Stefano)
shinyServer(function(input, output) {
data <- reactive({
tablefilecsv <- input$table
table <- read.csv2(tablefilecsv$name, header=TRUE)
})
observeEvent(input$table,{
output$tablesum <- renderDataTable(NULL)
})
observeEvent(input$BUTCS,{
output$tablesum <- renderDataTable({
d <- data()
tablesum <- cbind.data.frame(x=d$x, sum=(d$A+d$B))
}, options = list(paging=FALSE, searching=FALSE))
})
})