I have created the following shiny App
library(shiny)
library(rhandsontable)
ui <- fluidPage(
sidebarLayout(sidebarPanel = "Inputparameter",
selectInput(inputId = "Name", label = "Name", choices = c("A", "B", "C"))),
mainPanel (rHandsontableOutput(outputId = 'Adjusttable', width ='100%', height = 100%')))
server <- function(input, output, session) {
output$Adjusttable<-renderRHandsontable({
DF = data.frame(ID = 1:7,'Column2' = 0, Start = "D",FM="",stringsAsFactors = FALSE)
names(DF)[names(DF)=='Column2']<- input$Name
names(DF)[names(DF)=='FM']<-'FM'
DF$ID<-NULL
rhandsontable(DF, width = 280, height = 677,stretchH = "all") %>%
hot_col(col = "Start", type = "dropdown", source = c("Fw", "Sw"), fillHandle =
list(direction='vertical', autoInsertRow=TRUE))%>%
hot_context_menu(allowRowEdit = TRUE, allowColEdit = FALSE)
}, quoted = FALSE )}
shinyApp(ui, server)
The following results in an app with an editable table. When we fill values in the table,, and change the item in the name drop down, the values get reset to 0 and the table defaults to its default state. Is there a way to fill the table, change the number of rows, etc , change the name input and avoid resetting the table. I request someone to take a look.
Try this
library(shiny)
library(rhandsontable)
library(DT)
DF <- data.frame(ID = 1:7,Column2 = 0, Start = "D",FM="",stringsAsFactors = FALSE)
names(DF)[names(DF)=='FM']<-'FM'
DF$ID<-NULL
ui <- fluidPage(
sidebarLayout(
sidebarPanel( "Inputparameter",
selectInput(inputId = "Name", label = "Name", choices = c("A", "B", "C"))),
mainPanel( rHandsontableOutput(outputId = 'hot', width ='100%', height = '100%')
, DTOutput("t1")
)
)
)
server <- function(input, output, session) {
DF1 <- reactiveValues(data=DF)
observe({
input$Name
names(DF1$data)[1] <- input$Name
})
output$hot<-renderRHandsontable({
rhandsontable(DF1$data, width = 280, height = 677,stretchH = "all") %>%
hot_col(col = "Start", type = "dropdown", source = c("Fw", "Sw"), fillHandle =
list(direction='vertical', autoInsertRow=TRUE)) %>%
hot_context_menu(allowRowEdit = TRUE, allowColEdit = FALSE)
}, quoted = FALSE )
observe({
if (!is.null(input$hot)){
DF1$data <- (hot_to_r(input$hot))
}
})
output$t1 <- renderDT(DF1$data)
}
shinyApp(ui, server)
Related
I'm working on a table rendered with rhandsontable that uses dropdown menus for user inputs into the table. My dropdown approach is based on guidance provided in post Is there a way to have different dropdown options for different rows in an rhandsontable?. I'm trying to add a feature where the user clicks on an actionButton() in order to add a column to the table and sequentially numbers the header for the added column, with the dropdowns included in the added column. The below code almost works, except that added columns don't have the required dropdowns. What am I doing wrong here?
Code:
library(shiny)
library(rhandsontable)
ui <- fluidPage(br(),
mainPanel(
actionButton("add", "Add column"),br(),br(),
rHandsontableOutput("Tbl")
)
)
server <- function(input, output) {
DF <- reactiveVal(
data.frame(
'Series 1' = NA_character_,
stringsAsFactors = FALSE,
row.names = c("Select option"),
check.names = FALSE
)
)
observeEvent(input$Tbl,{DF(hot_to_r(input$Tbl))})
output$Tbl <- renderRHandsontable({
select_option <- c(NA_character_, "dog", "cat") # defines the dropdown options
tmp <- rhandsontable(DF(), rowHeaderWidth = 200, selectCallback = TRUE, height = 300) %>%
hot_cols(colWidths = 100) %>%
hot_col("Series 1",
allowInvalid = FALSE,
type = "dropdown",
source = NA_character_,
readOnly = TRUE
)
tmp <- hot_col(tmp,
col = "Series 1",
allowInvalid = FALSE,
type = "dropdown",
source = select_option
) %>%
hot_cell(row = input$Tbl_select$select$r, col = "Series 1", readOnly = FALSE)
tmp
})
observeEvent(input$add, {
select_option <- c(NA_character_, "dog", "cat") # defines the dropdown options
newCol <- data.frame('Series 1' = NA_character_,stringsAsFactors = FALSE)
names(newCol) <- paste("Series", ncol(hot_to_r(input$Tbl)) + 1)
DF(cbind(DF(), newCol))
})
}
shinyApp(ui = ui, server = server)
You need to apply hot_col(type = "dropdown") on every column of the reactive data.frame (col = names(DF())) not only on the first col = "Series 1":
library(shiny)
library(rhandsontable)
ui <- fluidPage(br(),
mainPanel(
actionButton("add", "Add column"),br(),br(),
rHandsontableOutput("Tbl")
)
)
server <- function(input, output) {
DF <- reactiveVal(
data.frame(
'Series 1' = NA_character_,
stringsAsFactors = FALSE,
row.names = c("Select option"),
check.names = FALSE
)
)
observeEvent(input$Tbl,{DF(hot_to_r(input$Tbl))})
output$Tbl <- renderRHandsontable({
select_option <- c(NA_character_, "dog", "cat") # defines the dropdown options
rhandsontable(DF(), rowHeaderWidth = 200, selectCallback = TRUE, height = 300) %>%
hot_cols(colWidths = 100) %>%
hot_col(col = names(DF()),
allowInvalid = FALSE,
type = "dropdown",
source = select_option
) %>%
hot_cell(row = input$Tbl_select$select$r, col = "Series 1", readOnly = FALSE)
})
observeEvent(input$add, {
select_option <- c(NA_character_, "dog", "cat") # defines the dropdown options
newCol <- data.frame('Series 1' = NA_character_,stringsAsFactors = FALSE)
names(newCol) <- paste("Series", ncol(hot_to_r(input$Tbl)) + 1)
DF(cbind(DF(), newCol))
})
}
shinyApp(ui = ui, server = server)
Following up on ismirsehregal's solution for column addition, the below offers both column addition and deletion via actionButton():
library(shiny)
library(rhandsontable)
ui <- fluidPage(br(),
mainPanel(
actionButton("add", "Add column"),br(),br(),
actionButton("delSeries","Select series below to delete"),
uiOutput("delSeries2"),
rHandsontableOutput("Tbl")
)
)
server <- function(input, output) {
DF <- reactiveVal(
data.frame(
'Series 1' = NA_character_,
stringsAsFactors = FALSE,
row.names = c("Select option"),
check.names = FALSE
)
)
observeEvent(input$Tbl,{DF(hot_to_r(input$Tbl))})
output$Tbl <- renderRHandsontable({
select_option <- c(NA_character_, "dog", "cat") # defines the dropdown options
tmp <- rhandsontable(DF(), rowHeaderWidth = 200, selectCallback = TRUE, height = 300) %>%
hot_cols(colWidths = 100) %>%
hot_col("Series 1",
allowInvalid = FALSE,
type = "dropdown",
source = NA_character_,
readOnly = TRUE
)
tmp <- hot_col(tmp,
col = names(DF()), # adding this is what fixed it
allowInvalid = FALSE,
type = "dropdown",
source = select_option
) %>%
hot_cell(row = input$Tbl_select$select$r, col = "Series 1", readOnly = FALSE)
tmp
})
observeEvent(input$add, {
newCol <- data.frame('Series 1' = NA_character_,stringsAsFactors = FALSE)
names(newCol) <- paste("Series", ncol(hot_to_r(input$Tbl)) + 1)
DF(cbind(DF(), newCol))
})
observeEvent(input$delSeries3, {
tmp <- DF()
delCol <- input$delSeries3
tmp <- tmp[ , !(names(tmp) %in% delCol), drop = FALSE]
newNames <- sprintf("Series %d",seq(1:ncol(tmp)))
names(tmp) <- newNames
DF(tmp)
})
output$delSeries2 <-
renderUI(
selectInput("delSeries3",
label = NULL,
choices = colnames(hot_to_r(input$Tbl)),
selected = "",
multiple = TRUE,
width = '110px')
)
}
shinyApp(ui = ui, server = server)
I have an app which has a DT table with row selection enabled. Is it possible to toggle between disabling and enabling the entire table without rerendering it? Using shinyjs::disable and shinyjs::enable will disable and enable the text boxes in the table used for filtering, but not the ability to select rows. I'm also not aware of any DT proxy method that would accomplish what I'm trying to do.
library(shiny)
library(DT)
library(shinyjs)
ui <- fluidPage(
DTOutput("table"),
actionButton(inputId = "disable",
label = "Disable"),
actionButton(inputId = "enable",
label = "Enable"),
useShinyjs()
)
server <- function(input, output, session) {
output$table <- renderDT({
data <- data.frame(COL_1 = c(1, 2, 3, 4),
COL_2 = c("A", "B", "C", "D"),
stringsAsFactors = FALSE)
datatable(data,
escape = FALSE,
filter = list(position = "top"),
rownames = FALSE)
})
observeEvent(input$disable, {
disable(id = "table")
})
observeEvent(input$enable, {
enable(id = "table")
})
}
shinyApp(ui = ui, server = server)
It seems there is no proxy method fitting your needs, accordingly you'll have to re-render your table.
However, you don't need library(shinyjs).
Please check the following:
library(shiny)
library(DT)
ui <- fluidPage(
DTOutput("table"),
actionButton(inputId = "disable",
label = "Disable"),
actionButton(inputId = "enable",
label = "Enable")
)
server <- function(input, output, session) {
dtSettings <- reactiveValues(searchable = TRUE, mode = "multiple")
output$table <- renderDT({
data <- data.frame(COL_1 = c(1, 2, 3, 4),
COL_2 = c("A", "B", "C", "D"),
stringsAsFactors = FALSE)
datatable(data,
escape = FALSE,
filter = list(position = "top"),
rownames = FALSE,
selection = list(mode = dtSettings$mode , selected = NULL, target = 'row'),
options = list(
columnDefs = list(list(targets = seq_len(ncol(data))-1, searchable = dtSettings$searchable)),
pageLength = 5
))
}, server = FALSE)
observeEvent(input$disable, {
dtSettings$searchable <- FALSE
dtSettings$mode <- "none"
})
observeEvent(input$enable, {
dtSettings$searchable <- TRUE
dtSettings$mode <- "multiple"
})
}
shinyApp(ui = ui, server = server)
I figured out that I could accomplish this by using event.stopPropagation() within the tbody element of the datatable.
library(shiny)
library(DT)
library(shinyjs)
ui <- fluidPage(
DTOutput("table"),
actionButton(inputId = "disable",
label = "Disable"),
actionButton(inputId = "enable",
label = "Enable"),
useShinyjs()
)
server <- function(input, output, session) {
output$table <- renderDT({
data <- data.frame(COL_1 = c(1, 2, 3, 4),
COL_2 = c("A", "B", "C", "D"),
stringsAsFactors = FALSE)
datatable(data,
escape = FALSE,
filter = list(position = "top"),
rownames = FALSE)
})
observeEvent(input$disable, {
runjs("document.getElementById('table').getElementsByTagName('tbody')[0].setAttribute('onmousedown', 'event.stopPropagation();');")
})
observeEvent(input$enable, {
runjs("document.getElementById('table').getElementsByTagName('tbody')[0].removeAttribute('onmousedown');")
})
}
shinyApp(ui = ui, server = server)
I want to create a tabsetPanel that displays a selection of dataframes based on a selectizeInput, while also allowing for permanent edits of the data. I use editable DataTables to render the dataframes but couldn't find a way to save the edits. This example code illustrates my problem:
library(shiny)
library(shinyWidgets)
library(shinyjs)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "dataframes", label = "select dataframes",
choices = c("iris", "mtcars", "DNase", "ChickWeight"), multiple = TRUE, options = list(create = T))
),
mainPanel(
uiOutput("dataframes_rendered")
)
)
)
server <- function(input, output) {
output$dataframes_rendered = renderUI({
# create one tab per df
tabs = lapply(input$dataframes, function(df){
output[[df]] = DT::renderDT(get(df), editable = T, rownames = F, options = list(dom = "t"))
tabPanel(title = df, value = NULL, dataTableOutput(outputId = df), br())
})
# create tabsetPanel
do.call(tabsetPanel, c(tabs, id = "df_tabset"))
})
}
shinyApp(ui = ui, server = server)
I understand why the edits are not saved in my example (the dataframes are re-rendered with every change in the selectizeInput) but, so far, everything I tried to to save the edits and re-render the editeed tables did not work.
Please try the below:
library(shiny)
library(shinyWidgets)
library(shinyjs)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "dataframes", label = "select dataframes",
choices = c("iris", "mtcars", "DNase", "ChickWeight"), multiple = TRUE, options = list(create = T))
),
mainPanel(
tabsetPanel(id = "df_tabset")
)
)
)
server <- function(input, output, session) {
tables <- reactiveValues(
iris = iris,
mtcars = mtcars,
DNase = DNase,
ChickWeight = ChickWeight,
df_tabset = NULL
)
observeEvent(input$dataframes, {
if (length(input$dataframes) > length(tables$df_tabset)) {
df = input$dataframes[! input$dataframes %in% tables$df_tabset]
output[[df]] = renderDT(tables[[df]], editable = T, rownames = F, options = list(dom = "t"))
appendTab(inputId = "df_tabset", select = TRUE,
tabPanel(title = df, value = df, DTOutput(outputId = df))
)
tables$df_tabset = input$dataframes
} else {
df = tables$df_tabset[! tables$df_tabset %in% input$dataframes]
removeTab(inputId = "df_tabset", target = df)
tables$df_tabset = input$dataframes
}
}, ignoreNULL = FALSE, ignoreInit = TRUE)
observeEvent(input$iris_cell_edit, {
tables$iris[input$iris_cell_edit$row, input$iris_cell_edit$col + 1] = input$iris_cell_edit$value
})
observeEvent(input$mtcars_cell_edit, {
tables$mtcars[input$mtcars_cell_edit$row, input$mtcars_cell_edit$col + 1] = input$mtcars_cell_edit$value
})
observeEvent(input$DNase_cell_edit, {
tables$DNase[input$DNase_cell_edit$row, input$DNase_cell_edit$col + 1] = input$DNase_cell_edit$value
})
observeEvent(input$ChickWeight_cell_edit, {
tables$ChickWeight[input$ChickWeight_cell_edit$row, input$ChickWeight_cell_edit$col + 1] = input$ChickWeight_cell_edit$value
})
}
shinyApp(ui = ui, server = server)
I also made a change to your code by adding and removing tabs rather than rerendering all of them each time.
The select = TRUE takes you to the added tab but this can be changed to the default of FALSE to remain on the current tab.
The main way of saving changes is to use reactives/reactiveValues. See DT Shiny and examples.
Update
Based on the comment below, I now create each observeEvent() as needed.
library(shiny)
library(shinyWidgets)
library(shinyjs)
library(DT)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectizeInput(inputId = "dataframes", label = "select dataframes",
choices = c("iris", "mtcars", "DNase", "ChickWeight"), multiple = TRUE, options = list(create = T))
),
mainPanel(
tabsetPanel(id = "df_tabset")
)
)
)
server <- function(input, output, session) {
tables <- reactiveValues(
iris = iris,
mtcars = mtcars,
DNase = DNase,
ChickWeight = ChickWeight,
df_tabset = NULL
)
observeEvent(input$dataframes, {
if (length(input$dataframes) > length(tables$df_tabset)) {
df = input$dataframes[! input$dataframes %in% tables$df_tabset]
output[[df]] = renderDT(tables[[df]], editable = T, rownames = F, options = list(dom = "t"))
appendTab(inputId = "df_tabset", select = TRUE,
tabPanel(title = df, value = df, DTOutput(outputId = df))
)
observeEvent(input[[paste0(df, '_cell_edit')]], {
tables[[df]][input[[paste0(df, '_cell_edit')]]$row, input[[paste0(df, '_cell_edit')]]$col + 1] = input[[paste0(df, '_cell_edit')]]$value
})
tables$df_tabset = input$dataframes
} else {
df = tables$df_tabset[! tables$df_tabset %in% input$dataframes]
removeTab(inputId = "df_tabset", target = df)
tables$df_tabset = input$dataframes
}
}, ignoreNULL = FALSE, ignoreInit = TRUE)
}
shinyApp(ui = ui, server = server)
What I am attempting to do, is to allow the user to pass in a configuration/lookup excel table into shiny, display this table in shiny, allow the user to make cells edits in shiny, and use the values that were edited from the editable table for calculations. My problem arises for the last step "use the values that were edited from the editable table for calculations".
The excel file consists of 2 tabs with data of the following content:
Tab1 Name: "parameters"
data.frame(Name = c("a", "b", "c"), Value = c(1:3))
Tab2 Name: "parameters2"
data.frame(Name = c("a", "b", "c"), Value = c(4:6))
The ideal shiny app would do the following:
1) At upload, perform a calculation adding the unchanged first values of Tab 1 and Tab 2. This would be 1 + 4 = 5.
2) If user edits Tab 1's value of 1 to 8, then the calculation would result in 8 + 4 = 12.
Effectively, I want to use the edited tables values to update all my calculations if the user makes any edits to it. I know this can be done by simply uploading a new file in shiny, but I would rather allow them to do this in shiny as opposed to uploading a new file.
Here is my shiny app. Appreciate any help/guidance!
library(shiny)
library(DT)
shinyApp(
ui <- fluidPage(
fileInput(inputId = "config", label = "Upload Configuration File",
multiple = F, accept = c(".xlsx", ".xls")),
verbatimTextOutput("txt"),
tagList(tags$head(tags$style(type = 'text/css','.navbar-brand{display:none;}')),
navbarPage(title = "",
tabPanel(title = "Parameters",
dataTableOutput(outputId = "edit.param", width = 2)),
tabPanel(title = "Parameters2",
dataTableOutput(outputId = "edit.param2", width = 2))
)
)
),
server = function(input, output, session) {
config.path = reactive({
inFile = input$config
if(is.null(inFile)) {
return(NULL)
} else {
return(inFile$datapath)
}
})
df.param = reactive({
read_excel(path = config.path(), sheet = "parameters")
})
df.param2 = reactive({
read_excel(path = config.path(), sheet = "parameters2")
})
output$edit.param = renderDT(df.param(), selection = "none", server = F, editable = "cell")
output$edit.param2 = renderDT(df.param2(), selection = "none", server = F, editable = "cell")
observeEvent(input$edit.param_cell_edit, {
df.param()[input$edit.param_cell_edit$row, input$edit.param_cell_edit$col] <<- input$edit.param_cell_edit$value
})
observeEvent(input$edit.param2_cell_edit, {
df.param()[input$edit.param2_cell_edit$row, input$edit.param2_cell_edit$col] <<- input$edit.param2_cell_edit$value
})
output$txt = reactive({
df.param()$value[1] + df.param2()$value[1]
})
}
)
I also tried this for the server section and had no luck either:
output$edit.param = renderDT(df.param(), selection = "none", server = F, editable = "cell")
output$edit.param2 = renderDT(df.param2(), selection = "none", server = F, editable = "cell")
observe(input$edit.param_cell_edit)
observe(input$edit.param2_cell_edit)
Could you try this? (I have not tried).
library(shiny)
library(DT)
shinyApp(
ui <- fluidPage(
fileInput(inputId = "config", label = "Upload Configuration File",
multiple = F, accept = c(".xlsx", ".xls")),
verbatimTextOutput("txt"),
tagList(tags$head(tags$style(type = 'text/css','.navbar-brand{display:none;}')),
navbarPage(title = "",
tabPanel(title = "Parameters",
dataTableOutput(outputId = "edit_param", width = 2)),
tabPanel(title = "Parameters2",
dataTableOutput(outputId = "edit_param2", width = 2))
)
)
),
server = function(input, output, session) {
config.path = reactive({
inFile = input$config
if(is.null(inFile)) {
return(NULL)
} else {
return(inFile$datapath)
}
})
df_param <- reactiveVal()
observe({
req(config.path())
df_param(read_excel(path = config.path(), sheet = "parameters"))
})
df_param2 <- reactiveVal()
observe({
req(config.path())
df_param2(read_excel(path = config.path(), sheet = "parameters2"))
})
output$edit_param = renderDT({
req(df_param())
datatable(isolate(df_param()), selection = "none", editable = "cell")
})
output$edit_param2 = renderDT({
req(df_param2())
datatable(isolate(df_param2()), selection = "none", editable = "cell")
})
proxy <- dataTableProxy("edit_param")
proxy2 <- dataTableProxy("edit_param2")
observeEvent(input$edit_param_cell_edit, {
info <- input$edit_param_cell_edit
df_param(editData(df_param(), info, proxy, resetPaging = FALSE))
})
observeEvent(input$edit_param2_cell_edit, {
info <- input$edit_param2_cell_edit
df_param2(editData(df_param2(), info, proxy2, resetPaging = FALSE))
})
output$txt = renderPrint({
df_param()$value[1] + df_param2()$value[1]
})
}
)
This question is an extension of the question I posted: this question
I created a dataframe with 3 columns: num, id and val. I want my shiny app to do the following:
a dataframe dat is filtered by num column
select an value from id column from dat (selectInput).
add text comment in a text box (textInput)
click on an action button
A new column called comment is created in the data table, text comments are added to the comment column in the row where id equals the value selected.
The code is below. I cannot figure out why it's not working.
Thank a lot in advance!
library(shiny)
library(DT)
dat = data.frame(num=rep(1:2, each=5), id=rep(LETTERS[1:5],2), val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10, selected='')),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df = reactive ({ dat %>% filter(num %in% input$selectNum) })
df_current <- reactiveVal(df())
observeEvent(input$button, {
req(df_current())
## update df by adding comments
df_new <- df_current()
df_new[df_current()$id %in% input$selectID, "Comment"] <- input$comment
df_current(df_new)
})
output$data <- DT::renderDataTable({
req(df_current())
DT::datatable(df_current(),
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5))
})
shinyApp(ui=ui, server=server)
Instead of using a reactive/eventReactive statement for df, it might be more natural to keep track of previously inputted comments in the Comment column using a reactiveVal object for df. See also the responses to this question: R Shiny: reactiveValues vs reactive. If you prefer to use a reactive/eventReactive statement for df it is probably better to work with a separate object to store previous input comments (instead of incorporating it into the reactive statement for df).
library(shiny)
library(DT)
dat = data.frame(num=1:10, id=LETTERS[1:10], val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10)),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df_current <- reactiveVal(dat)
observeEvent(input$button, {
req(df_current(), input$selectID %in% dat$id)
## update df by adding comments
df_new <- df_current()
df_new[df_current()$id %in% input$selectID, "Comment"] <- input$comment
df_current(df_new)
})
output$data <- DT::renderDataTable({
req(df_current())
## filter df_current by 'selectNum'
df_filtered <- df_current()[df_current()$num %in% input$selectNum, ]
## show comments if non-empty
showComments <- is.null(df_filtered$Comment) || !all(is.na(df_filtered$Comment))
DT::datatable(df_filtered,
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5,
columnDefs = list(
list(targets = ncol(df_filtered), visible = showComments)
)
)
)
})
}
shinyApp(ui=ui, server=server)
Edit: below an edited server function that using df_current <- reactive({...}) instead of df_current <- reactiveVal({...}) and defining a separate reactiveVal object to keep track of the comments.
server <- function(input, output, session) {
## initialize separate reactive object for comments
df_comments <- reactiveVal({
data.frame(
id = character(0),
Comment = character(0),
stringsAsFactors = FALSE
)
})
## reactive object df
df_current <- reactive({
## reactivity that df depends on
## currently df = dat does not change
df <- dat
## merge with current comments
if(nrow(df_comments()) > 0)
df <- merge(df, df_comments(), by = "id", all.x = TRUE)
return(df)
})
observeEvent(input$button, {
req(input$selectID)
## update df_comments by adding comments
df_comments_new <- rbind(df_comments(),
data.frame(id = input$selectID, Comment = input$comment)
)
## if duplicated id's keep only most recent rows
df_comments_new <- df_comments_new[!duplicated(df_comments_new$id, fromLast = TRUE), , drop = FALSE]
df_comments(df_comments_new)
})
output$data <- DT::renderDataTable({
req(df_current())
## filter df_current by 'selectNum'
df_filtered <- df_current()[df_current()$num %in% input$selectNum, ]
## show comments if non-empty
showComments <- is.null(df_filtered$Comment) || !all(is.na(df_filtered$Comment))
DT::datatable(df_filtered,
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5,
columnDefs = list(
list(targets = ncol(df_filtered), visible = showComments)
)
)
)
})
}
There you have got a working example.
I think the thing is that you are trying to update a value through an observeEvent which is not good according to the documentation. ?observeEvent
Use observeEvent whenever you want to perform an action in response to an event. (Note that "recalculate a value" does not generally count as performing an action–see eventReactive for that.)
library(shiny)
library(DT)
dat = data.frame(num=1:10, id=LETTERS[1:10], val=rnorm(10))
ui = fluidPage(
fluidRow(
column(12, selectInput('selectNum', label='Select Num',
choices=1:10, selected='')),
column(2, selectInput(inputId = 'selectID',
label = 'Select ID2',
choices = LETTERS[1:10],
selected='',
multiple=TRUE)),
column(6, textInput(inputId = 'comment',
label ='Please add comment in the text box:',
value = "", width = NULL,
placeholder = NULL)),
column(2, actionButton(inputId = "button",
label = "Add Comment"))
),
fluidRow (
column(12, DT::dataTableOutput('data') )
)
)
server <- function(input, output, session) {
## make df reactive
df_current = reactive({
df = dat %>% filter(num %in% input$selectNum)
if(input$button != 0) {
input$button
df[df$id %in% input$selectID, "Comment"] <- isolate(input$comment)
}
return(df)
})
output$data <- DT::renderDataTable({
req(df_current())
DT::datatable(df_current(),
options = list(orderClasses = TRUE,
lengthMenu = c(5, 10, 20), pageLength = 5))
})
}
shinyApp(ui=ui, server=server)
So you can either go with your reactive value or using eventReactive as stated in the doc.