How to render dynamic object outputs horizontally instead of vertically? - r

The below code is "dynamic" in allowing the user to render additional independent tables with the click of the action button. For the sake of brevity, the below code has certain features removed such as table deletion, table column summation, etc.
When running the code note how added tables are rendered vertically. How could I render added tables horizontally instead of vertically?
I ordinarily render horizontally by using Shiny's grid layout, setting up columns, etc. But since these tables are dynamically rendered with the number of tables an unknown, I don't know how to do this.
Code:
library(rhandsontable)
library(shiny)
rowNames1 <- c("A", "B", "C", "Sum")
data1 <- data.frame(row.names = rowNames1, "Col 1" = c(1, 1, 0, 2), check.names = FALSE)
ui <- fluidPage(
rHandsontableOutput("hottable1"),
actionButton("addTbl", "Add table"),
tags$div(id = "placeholder")
)
server <- function(input, output) {
uiTbl1 <- reactiveValues(base = data1)
observeEvent(input$hottable1,{uiTbl1$base <- hot_to_r(input$hottable1)})
output$hottable1 <- renderRHandsontable({
rhandsontable(uiTbl1$base, rowHeaderWidth = 100, useTypes = TRUE)
})
observeEvent(input$addTbl, {
divID <- gsub("\\.", "", format(Sys.time(), "%H%M%OS3"))
dtID <- paste0(divID, "DT")
uiTbl1[[paste0(divID,"tbl")]] <- data1
insertUI(
selector = "#placeholder",
ui = tags$div(
id = divID,
rHandsontableOutput(dtID),
hr()
)
)
output[[dtID]] <- renderRHandsontable({
req(uiTbl1[[paste0(divID,"tbl")]])
rhandsontable(uiTbl1[[paste0(divID,"tbl")]], rowHeaderWidth = 100, useTypes = TRUE)
})
})
}
shinyApp(ui, server)

Try this:
insertUI(
selector = "#placeholder",
ui = tags$div(
id = divID,
style = "display: inline-block;",
rHandsontableOutput(dtID),
hr()
)
)
Not tested... perhaps you'll have to set the width.

Related

How to break dependence between tables dynamically rendered in R Shiny App?

In the below code, I took one of the examples from https://community.rstudio.com/t/shiny-app-with-dynamic-number-of-datatables/2405/4 for dynamically adding tables. The example used tables rendered with DT and I made minor modifications to use it for rhandsontable.
However, I'm having trouble making the tables independent of one another. When adding a new table, it should be "seeded" with the default values per dataframe data1 and its related rowNames1, but thereafter they should be independent as illustrated below. I'm fairly sure the solution has something to do with creating a dynamic equivalent of the reactive uiTable1 used in the code for holding table values, but I don't know how to do this.
Any ideas for accomplishing this?
Inputs into the base (master) and added tables will be used elsewhere in the full code this is intended for.
Code:
library(rhandsontable)
library(shiny)
rowNames1 <- c('A','B','C','Sum')
data1 <- data.frame(row.names = rowNames1, 'Col 1' = c(1,1,0,2), check.names = FALSE)
ui <- fluidPage(
rHandsontableOutput('hottable1'), # undeletable base table
actionButton("addTbl", "Add table"), # adds new table
tags$div(id = "placeholder")
)
server <- function(input, output) {
uiTable1 <- reactiveVal(data1) # undeletable base table
rv <- reactiveValues() # used for dynamic table add/removal
# records changes to base table and will need same for added tables:
observeEvent(input$hottable1,{uiTable1(hot_to_r(input$hottable1))})
output$hottable1 <- renderRHandsontable({
rhandsontable(uiTable1(),rowHeaderWidth = 100, useTypes = TRUE)
})
# adds column summation to last row of table, will need for all added tables too:
observe({
req(input$hottable1)
DF <- hot_to_r(input$hottable1)
DF[setdiff(rowNames1, "Sum"),]
DF["Sum",] <- colSums(DF[setdiff(rowNames1, "Sum"),, drop = FALSE], na.rm = TRUE)
uiTable1(DF)
})
# dynamically add/remove tables:
observeEvent(input$addTbl, {
divID <- gsub("\\.", "", format(Sys.time(), "%H%M%OS3"))
dtID <- paste0(divID, "DT")
btnID <- paste0(divID, "rmv")
insertUI(
selector = "#placeholder",
ui = tags$div(id = divID,
actionButton(btnID, "Remove table", class = "pull-left btn btn-danger"),
rHandsontableOutput(dtID),
hr()
)
)
output[[dtID]] <- renderRHandsontable({
rhandsontable(uiTable1(),rowHeaderWidth = 100, useTypes = TRUE)
})
# remove table from the app when remove button clicked
observeEvent(input[[btnID]], {
removeUI(selector = paste0("#", divID))
rv[[divID]] <- NULL
}, ignoreInit = TRUE, once = TRUE)
})
}
shinyApp(ui,server)
We can use reactiveValues to store the information of each new table. These tables will start with the values of the base table available at that time. Afterwards they will stop reacting to changes inside the main table.
First we create the base table uiTable1 <- reactiveValues(table_base = data1) # undeletable base table
And finally all the subsequent tables will be created as uiTable1[[glue("{divID}table")]] <- uiTable$table_base
library(rhandsontable)
library(shiny)
library(glue)
rowNames1 <- c("A", "B", "C", "Sum")
data1 <- data.frame(row.names = rowNames1, "Col 1" = c(1, 1, 0, 2), check.names = FALSE)
ui <- fluidPage(
rHandsontableOutput("hottable1"), # undeletable base table
actionButton("addTbl", "Add table"), # adds new table
tags$div(id = "placeholder")
)
server <- function(input, output) {
uiTable1 <- reactiveValues(table_base = data1) # undeletable base table
rv <- reactiveValues() # used for dynamic table add/removal
# records changes to base table and will need same for added tables:
observeEvent(input$hottable1, {
uiTable1$table_base <- hot_to_r(input$hottable1)
})
output$hottable1 <- renderRHandsontable({
rhandsontable(uiTable1$table_base, rowHeaderWidth = 100, useTypes = TRUE)
})
# adds column summation to last row of table, will need for all added tables too:
observe({
req(input$hottable1)
DF <- hot_to_r(input$hottable1)
DF[setdiff(rowNames1, "Sum"), ]
DF["Sum", ] <- colSums(DF[setdiff(rowNames1, "Sum"), , drop = FALSE], na.rm = TRUE)
uiTable1$table_base <- DF
})
# dynamically add/remove tables:
observeEvent(input$addTbl, {
divID <- gsub("\\.", "", format(Sys.time(), "%H%M%OS3"))
dtID <- paste0(divID, "DT")
btnID <- paste0(divID, "rmv")
# capture the current state of the main table
uiTable1[[glue("{divID}table")]] <- uiTable1$table_base
insertUI(
selector = "#placeholder",
ui = tags$div(
id = divID,
actionButton(btnID, "Remove table", class = "pull-left btn btn-danger"),
rHandsontableOutput(dtID),
hr()
)
)
output[[dtID]] <- renderRHandsontable({
req(uiTable1[[glue("{divID}table")]])
rhandsontable(uiTable1[[glue("{divID}table")]], rowHeaderWidth = 100, useTypes = TRUE)
})
# adds column summation to last row of table, will need for all added tables too:
observeEvent(input[[dtID]], {
DF <- hot_to_r(input[[dtID]])
DF[setdiff(rowNames1, "Sum"), ]
DF["Sum", ] <- colSums(DF[setdiff(rowNames1, "Sum"), , drop = FALSE], na.rm = TRUE)
uiTable1[[glue("{divID}table")]] <- DF # update the table with the sum
})
# remove table from the app when remove button clicked
observeEvent(input[[btnID]],
{
removeUI(selector = paste0("#", divID))
rv[[divID]] <- NULL
uiTable1[[glue("{divID}table")]] <- NULL
},
ignoreInit = TRUE,
once = TRUE
)
})
}
shinyApp(ui, server)

How to replace an observeEvent with a more comprehensive reactive function in R Shiny?

The code at the bottom of this post works as intended, using observeEvent(input$choices...) in the server section. The use of input$choices is a simplification for sake of example ease. In the fuller code this excerpt derives from, the equivalent of "choices" is molded by many different inputs (call it a "floating reactive"), and unless I misunderstand observeEvent(), it won't be feasible to use observeEvent() in the fuller code because I would have to list the myriad inputs that can alter it. So, is there a way to genericize this code where it instantly captures any change to "choices" (again, "choices" is a simplified analogy for my more complex floating reactive) and outputs it to the 2nd row of the table, including added rows?
Also in the below image, I show how "choices" is a always parachuted into the 2nd position of the dataframe in all circumstances (maybe there's a simpler way to do this too):
Code:
library(rhandsontable)
library(shiny)
mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Floating reactive','Term C','Term D')
ui <- fluidPage(br(),
useShinyjs(),
uiOutput("choices"),br(),
rHandsontableOutput('hottable'),br(),
fluidRow(
column(1,actionButton("addSeries", "Add",width = '70px')),
column(3,hidden(uiOutput("delSeries2")))
)
)
server <- function(input, output) {
uiTable <- reactiveVal(mydata)
observeEvent(input$hottable, {uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)
})
observeEvent(input$choices,{
tmpTable <- uiTable()
tmpTable[2,]<- as.numeric(input$choices)
uiTable(tmpTable)
})
output$choices <-
renderUI({
selectInput(
"choices",
label = "User selects value to reflect in row 2 of table below:",
choices = c(1,2,3)
)
})
observeEvent(input$addSeries, {
newCol <- data.frame(c(1,1,0,1))
newCol[2,] <- as.numeric(input$choices)
names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable)) + 1)
uiTable(cbind(uiTable(), newCol))
})
output$delSeries2 <-
renderUI(
selectInput(
"delSeries3",
label = NULL,
choices = colnames(hot_to_r(input$hottable))
)
)
}
shinyApp(ui,server)
Not sure if I get the point here, but you might want to use observe instead of observeEvent to avoid managing the reactive dependencies (eventExpr) yourself:
library(rhandsontable)
library(shiny)
library(shinyjs)
mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Floating reactive','Term C','Term D')
ui <- fluidPage(br(),
useShinyjs(),
uiOutput("choices"),br(),
rHandsontableOutput('hottable'),br(),
fluidRow(
column(1,actionButton("addSeries", "Add",width = '70px')),
column(3,hidden(uiOutput("delSeries2")))
)
)
server <- function(input, output) {
uiTable <- reactiveVal(mydata)
observeEvent(input$hottable, {uiTable(hot_to_r(input$hottable))})
output$hottable <- renderRHandsontable({
rhandsontable(uiTable(),rowHeaderWidth = 100, useTypes = TRUE)
})
observe({
req(input$choices)
tmpTable <- uiTable()
tmpTable[2,] <- as.numeric(input$choices)
uiTable(tmpTable)
})
output$choices <-
renderUI({
selectInput(
"choices",
label = "User selects value to reflect in row 2 of table below:",
choices = c(1,2,3)
)
})
observeEvent(input$addSeries, {
newCol <- data.frame(c(1,1,0,1))
newCol[2,] <- as.numeric(input$choices)
names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable)) + 1)
uiTable(cbind(uiTable(), newCol))
})
output$delSeries2 <-
renderUI(
selectInput(
"delSeries3",
label = NULL,
choices = colnames(hot_to_r(input$hottable))
)
)
}
shinyApp(ui,server)

In R Shiny, how to eliminate the flashing of observeEvent conditionals when first invoking the App?

In the below MWE code, the object input2 is optionally called by the user by clicking the "Show" radio button for Input 2. Default setting is to hide input2. However, when first invoking the App, input2 quickly flashes by before being hidden by the observeEvent.
This flashing is much more pronounced in the non-MWE version of the code.
There is a related post In R shiny, how to eliminate flashing of all conditional panels in sidebar when first invoking the App without using renderUI? that addresses this issue for conditionalPanel. But here there is no conditionalPanel.
I do not want to use renderUI to resolve this issue!! As renderUI has drawbacks I don't want to re-introduce.
MWE code:
library(shiny)
library(shinyjs)
f <- function(action,i){as.character(checkboxInput(paste0(action,i),label=NULL))}
actions <- c("show", "reset")
tbl <- t(outer(actions, c(1,2), FUN = Vectorize(f)))
colnames(tbl) <- c("Show", "Reset")
rownames(tbl) <- c("Input 2", "Input 3")
ui <- fluidPage(
useShinyjs(),
tags$head(
tags$style(HTML(
"td .checkbox {margin-top: 0; margin-bottom: 0;}
td .form-group {margin-bottom: 0;}"
))
),
br(),
sidebarLayout(
sidebarPanel(
numericInput("input1", "Input 1:", 10, min = 1, max = 100),
h5(strong("Add inputs:")),
tableOutput("checkboxes"),
numericInput("input2", "Input 2:", 10, min = 1, max = 100),
),
mainPanel()
)
)
server <- function(input, output, session){
output[["checkboxes"]] <-
renderTable({tbl},
rownames = TRUE, align = "c",
sanitize.text.function = function(x) x
)
observeEvent(input[["show1"]], {
if(input[["show1"]] %% 2 == 1){shinyjs::show(id = "input2")} else
{shinyjs::hide(id = "input2")}
})
}
shinyApp(ui, server)
It takes some time in the event loop until observerEvent is called the first time.
By default, it will be displayed at the very beginning.
This results into a flash.
Just hide input2 at the very beginning of the server function:
server <- function(input, output, session) {
# Avoid flashing
shinyjs::hide(id = "input2")
output[["checkboxes"]] <-
renderTable(
{
tbl
},
rownames = TRUE,
align = "c",
sanitize.text.function = function(x) x
)
observeEvent(input[["show1"]], {
if (input[["show1"]] %% 2 == 1) {
shinyjs::show(id = "input2")
} else {
shinyjs::hide(id = "input2")
}
})
}
You can also use hidden
hidden(numericInput("input2", "Input 2:", 10, min = 1, max = 100))
and toggle:
observeEvent(input[["show1"]], {
toggle("input2")
},ignoreNULL = FALSE)

How to combine multiple inputs in one vector in shiny. Number of inputs depends on user's choice

I'm trying to create an UI in which user can choose some objects (as many as they want) and their respective weights. The weight input fields appear only when there's more than one object and increase as the user selects more objects. This part already works.
What I need is a vector that holds all the weights saved in the w1, w2 and so on.
I've tried using for loops and sapply with get() function but can't access the input$w1, input$w2 etc.
library(shiny)
# Create list of objects
object_list <- vector()
object_list <- paste0("O_", 1:10)
names(object_list) <- paste("Object", 1:10)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic UI"),
dashboardSidebar(
width = 700,
fluidRow(
column(7, selectInput("chosen_objects", "Chosen objects", choices = object_list, multiple = TRUE, width = "100%")),
column(5, uiOutput("weights"))
)
),
dashboardBody(
fluidPage(tabBox(width=2500,
tabPanel(
title = "Table"
)
)
)
)
)
server <- function(input,output) {
objects_number <- reactive({length(input$chosen_objects)})
output$weights <- renderUI({
if (is.na(objects_number()) | objects_number() <= 1)
return(NULL)
lapply(1:objects_number(), function(i) {
id <- paste0("w", i)
textInput(id, paste("Weight of", input$chosen_objects[i]), value = input[[id]], width = "50%", placeholder = "%")
})
})
}
shinyApp(ui, server)
Is there a way to collect the dynamic inputs in one vector or list?
I have made a few changes and based on your code I think you are good enough to see and get them by yourself. Let me know if you have any questions -
library(shiny)
# Create list of objects
object_list <- vector()
object_list <- paste0("O_", 1:10)
names(object_list) <- paste("Object", 1:10)
ui <- dashboardPage(
dashboardHeader(title = "Dynamic UI"),
dashboardSidebar(
width = 700,
fluidRow(
column(7, selectInput("chosen_objects", "Chosen objects",
choices = object_list, multiple = TRUE, width = "100%")),
column(5, uiOutput("weights"))
)
),
dashboardBody(
fluidPage(tabBox(width=2500,
tabPanel(
title = "Table",
verbatimTextOutput("weight_output")
)
)
)
)
)
server <- function(input,output) {
objects_number <- reactive({length(input$chosen_objects)})
output$weights <- renderUI({
if (is.na(objects_number()) | objects_number() <= 1)
return(NULL)
lapply(gsub("[A-Z]+_", "", input$chosen_objects), function(i) {
id <- paste0("w", i)
textInput(id, paste("Weight of", paste0("O_", i)),
value = NULL, width = "50%", placeholder = "%")
})
})
output$weight_output <- renderPrint({
req(input$chosen_objects)
sapply(paste0("w", gsub("[A-Z]+_", "", input$chosen_objects)), function(a) input[[a]])
})
}
shinyApp(ui, server)

How to add comment to a reactive data table in shiny

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.

Resources