I need to generate dynamically user interface in my shiny App. This involves inserting rpivotTable to UI page under some conditions with insertUI. I found that I can successfully do it only ones. After removing the element and inserting it again it do not appear. The issue is with rpivotTable only. All other interface elements like dataTable, actionButton so on work well. Here is the sample code reproducing the issue:
library(shiny)
library(rpivotTable)
ui<- fluidPage(title="test page",
actionButton("A","insert pivot"),
actionButton("B","remove pivot")
)
server<- function (input, output, session)
{
ds<-data.frame(a="1",b="2")
observeEvent(input$A,{
cat("insert\n")
insertUI(selector="#B",
where="afterEnd",
ui=rpivotTableOutput("C"),
immediate = T)
output$C <- renderRpivotTable({ rpivotTable(data = ds) })
})
observeEvent(input$B,{
cat("remove\n")
removeUI(selector="div#C",immediate = T)
})
}
shinyApp(ui,server)
Any advises how to solve this?
This question was posted also as an issue in rpivotTable GitHub and was answered there with the solution code below:
library(shiny)
library(rpivotTable)
ui<- fluidPage(title="test page",
actionButton("A","insert pivot"),
actionButton("B","remove pivot"),
div(id = 'placeholder')
)
server<- function (input, output, session)
{
ds<-data.frame(a="1",b="2")
inserted <- c()
observeEvent(input$A, {
btn <- input$A
id <- paste0('txt', btn)
insertUI(
selector = '#placeholder',
## wrap element in a div with id for ease of removal
ui = div(
rpivotTable(ds),
id = id
))
inserted <<- c(id, inserted)
})
observeEvent(input$B, {
removeUI(
## pass in appropriate div id
selector = paste0('#', inserted[length(inserted)])
)
inserted <<- inserted[-length(inserted)]
})
}
shinyApp(ui,server)
I assume the solution is basically to use new unique Id for each new insertUI.
Related
The code at the bottom is taken from an example in https://shiny.rstudio.com/articles/modules.html though I de-modularized it so I can understand something more basic. With this code, each click of the action button renders a counter which counts the number of clicks. Fine.
Instead of counting the number of clicks in the same output of verbatimTextOutput() as the code currently works, I'd like each click to be represented as a new output of verbatimTextOutput(). See illustration below which shows what I'm trying to derive, assuming the user clicks the action button 3 times. I don't know how many times the user will click the action button so there's no way to pre-set or hard-code the number of outputs and assign output names such as output$out1, output$output2, etc. Is there a way to reactively generate the outputs names, as a I naively attempted in the below code with output$"paste(out,count())" and verbatimTextOutput("paste(out,count())") (without the quote marks, I only put them in so the example code would work)? If this is possible this could be a way to achieve the results I am seeking.
Illustration:
Code:
library(shiny)
newOutput <- function(x,y){verbatimTextOutput("paste(out,count())")}
ui <- fluidPage(uiOutput("uiButton"))
server <- function(input,output,session){
count <- reactiveVal(0)
observeEvent(input$button, {count(count() + 1)})
output$"paste(out,count())" <- renderText({count()})
count
output$uiButton <-
renderUI(
tagList(
actionButton("button", label = "Click me"),
newOutput()
)
)
}
shinyApp(ui, server)
This is an alternative approach using insertUI.
Compared to #stefan's renderUI based solution it has the advantage, that the UI elements are rendered only once. Using renderUI every element is re-rendered on button click, accordingly things will slow down depending on the number of elements.
library(shiny)
ui <- fluidPage(
actionButton("add", "Add UI")
)
server <- function(input, output, session) {
observeEvent(input$add, {
output_name <- paste0("out_", input$add)
output[[output_name]] <- renderText({
isolate(input$add)
})
insertUI(
selector = ifelse(input$add == 0L, "#add", paste0("#", "out_", input$add-1)),
where = "afterEnd",
ui = verbatimTextOutput(output_name)
)
}, ignoreNULL = FALSE)
}
shinyApp(ui, server)
Also check ?removeUI.
Adapting this example to dynamically create graphs to your example you could do:
library(shiny)
library(purrr)
newOutput <- function(x) {
verbatimTextOutput(x)
}
ui <- fluidPage(
actionButton("button", label = "Click me"),
uiOutput("uiText")
)
server <- function(input, output, session) {
count <- reactiveVal(0)
observeEvent(input$button, {
count(count() + 1)
i <- count()
output_name <- paste("out", i)
output[[output_name]] <- renderText({
i
})
})
output$uiText <- renderUI({
out_list <- map(seq_len(count()), ~ {
tagList(
newOutput(paste("out", .x))
)
})
tagList(out_list)
})
}
shinyApp(ui, server)
I am trying to create an R Shiny app which requires nested modules. My code is functional when calling a single nested module but fails when I go one level deeper. The ui component is being created without issue, but the buttons etc. do not work within this module.
I have attached a simple example. Here, when you press the first button, it calls a module and creates a second button within a wellPanel. This is then repeated if this second button is pressed. However, I would expect that when I press the third button, I would get the string
Third button Pressed
printed to screen.
Any suggestions?
library(shiny)
# Second Level Mod --------------------------------------------------------
second_mod_ui <- function(id) {
ns <- shiny::NS(id)
fluidPage(
wellPanel(
actionButton(ns('addButton3'), '', icon = icon('plus'))
)
)
}
second_mod_server <- function(input, output, session) {
observeEvent(input$addButton3, {
print("Third button Pressed")
})
}
# First Level Mod ---------------------------------------------------------------
first_mod_ui <- function(id) {
ns <- shiny::NS(id)
shiny::uiOutput(ns("showButton"))
}
first_mod_server <- function(input, output, session) {
ns <- session$ns
output$showButton <- renderUI({
fluidPage(
wellPanel(
actionButton(ns('addButton2'), '', icon = icon('plus'))
)
)
})
observeEvent(input$addButton2, {
i <- sprintf('%04d', input$addButton2)
id <- sprintf('Button2%s', i)
insertUI(
selector = paste0('#', ns("addButton2")),
where = "beforeBegin",
ui = second_mod_ui(id)
)
callModule(second_mod_server, id)
})
}
# Main App ----------------------------------------------------------------
ui <- fluidPage(
br(),
actionButton('addButton1', '', icon = icon('plus'))
)
server <- function(input, output) {
# If the Plus button has been pressed
observeEvent(input$addButton1, {
# Create a new id
i <- sprintf('%04d', input$addButton1)
id <- sprintf('Button1%s', i)
# Insert the new UI
insertUI(
selector = '#addButton1',
where = "beforeBegin",
ui = first_mod_ui(id)
)
# Call the server
callModule(first_mod_server, id)
})
}
shinyApp(ui = ui, server = server)
I’m looking for some help with a simple Shiny app with a modularised design please. I think the problem is a name space issue so the example below is set out as a simplified version of my actual project.
The aim is for ‘tab_3’ on the tabsetPanel to only show when the ‘View Tab_3’ is checked, which works fine. I would like to update the tabsetPanel however to also select ‘tab_3’ when ‘View Tab_3’ is checked and this is not firing as desired.
I can get the tabsetPanel to also select ‘tab_3’ when ‘View Tab_3’ is checked if I wrap the tabsetPanel’s id in a namespace function, id = ns("tab_a_tha"), however then I lose the show/hide functionality of ‘tab_3’.
My hunch is that the solution lies within providing a namespace to the toggle function but I haven’t found any clues on how to approach it.
library(shiny)
library(shinyjs)
inner_moduleUI <- function(id){
ns <- NS(id)
tagList(
fluidRow(checkboxInput(ns("chckbx"), "View Tab_3", value = F)),
tabsetPanel(
id = "tab_a_tha",
# id = ns("tab_a_tha"),
tabPanel('tab_1'),
tabPanel('tab_2'),
tabPanel('tab_3')
)
)
}
inner_module <- function(input, output, session){
observeEvent(input$chckbx, {
toggle(condition = input$chckbx, selector = "#tab_a_tha li a[data-value=tab_3]")
if(input$chckbx == T){
updateTabsetPanel(session, 'tab_a_tha', selected = 'tab_3')
}
})
}
ui <- fluidPage(
useShinyjs(),
uiOutput('main_ui')
)
server <- function(input, output, session) {
output$main_ui <- renderUI({inner_moduleUI('inner_ns') })
callModule(inner_module, 'inner_ns')
}
shinyApp(ui = ui, server = server)
you are right the problem is with the namespace. The trick is that you can access the namespace function also in the server part of a module with session$ns.
Using this and wrapping the tap id in the ns function. We can use paste0 to generate the new selector of the toggle function. We get something like this:
library(shiny)
library(shinyjs)
inner_moduleUI <- function(id){
ns <- NS(id)
tagList(
fluidRow(checkboxInput(ns("chckbx"), "View Tab_3", value = F)),
tabsetPanel(
id = ns("tab_a_tha"),
# id = ns("tab_a_tha"),
tabPanel('tab_1'),
tabPanel('tab_2'),
tabPanel('tab_3')
)
)
}
inner_module <- function(input, output, session){
observeEvent(input$chckbx, {
toggle(condition = input$chckbx, selector = paste0("#",session$ns("tab_a_tha")," li a[data-value=tab_3]"))
if(input$chckbx == T){
updateTabsetPanel(session, 'tab_a_tha', selected = 'tab_3')
}
})
}
ui <- fluidPage(
useShinyjs(),
uiOutput('main_ui')
)
server <- function(input, output, session) {
output$main_ui <- renderUI({inner_moduleUI('inner_ns') })
callModule(inner_module, 'inner_ns')
}
shinyApp(ui = ui, server = server)
I'm trying to make a dynamically generated navbar based on the session user id.
I have a data table that maps the session user to a list of that user's clients. I want the app to produce a navbar where each tabPanel is for each client that user has. I'm not sure how I can easily do that since navbarPage() doesn't take a list argument.
Below is my example
library(shiny)
data <- data.frame(user=c("emily", "emily"), clients=c("client1", "client2"))
CreateCustomNavbarContent <- function(data) {
l <- lapply(data$clients, function(client) {
tabPanel(client,
h2(client))
})
renderUI({
l
})
}
shinyApp(
ui <- fluidPage(
uiOutput("custom_navbar")
),
server <- function(input, output) {
output$custom_navbar <- renderUI({
## commented below doesn't work
# navbarPage(
# CreateCustomNavbarContent(data)
# )
navbarPage("",
tabPanel("client1",
h2("client1")
),
tabPanel("client2",
h2("client2")
)
)
})
}
)
You could achieve what you want with do.call, so we can pass a list of arguments as separate arguments. Below is a working example, I gave emily a companion called John so you can validate that the code does what you want ;)
Hope this helps!
library(shiny)
data <- data.frame(user=c("Emily", "Emily","John","John"), clients=c("client1", "client2","client3","client4"))
ui = fluidPage(
selectInput('select_user','Select user:',unique(data$user)),
uiOutput('mytabsetpanel')
)
server = function(input, output, session){
output$mytabsetpanel = renderUI({
myTabs = lapply(data$clients[data$user==input$select_user], tabPanel)
do.call(tabsetPanel, myTabs)
})
}
shinyApp(ui,server)
I want to insert a hyperlink to DT table in shiny.
To save the loading time, I want to insert hyperlinks to current view (input$table_rows_current).
I have tired with observing but I don't know how to specify where to insert hyperlink and how?
Any help much appreciated.
Here is the sample code:
library(shiny)
createLink <- function(val) {
sprintf('<a href="https://www.google.com/#q=%s" target="_blank" >%s</a>',val,val)
}
ui <- fluidPage(
titlePanel("Table with Links!"),
sidebarLayout(
sidebarPanel(
h4("Click the link in the table to see
a google search for the car.")
),
mainPanel(
dataTableOutput('table1')
)
)
)
server <- function(input, output) {
output$table1 <- renderDataTable({
dt <- datatable(mtcars, escape=FALSE, selection = 'none') %>% formatStyle(0, cursor = 'pointer')
})
observe({
List <- input$table1_rows_current
List <- createLink(List)
return(List)
})
}
shinyApp(ui, server)
The function createLink is not working because you missed one val:
Corrected:
createLink <- function(val,val) {
sprintf('<a href="https://www.google.com/#q=%s' target="_blank" >%s</a>',val,val)
}
Then you can use createLink() as below:
input$table1_rows_current = createLink(input$table1_rows_current,
input$table1_rows_current)
It will show you embedded link column.