attempting bs_modal and bs_attach_modal inside renderUI

[desaija-lilly]

I am developing a rather UI-complex Shiny app, that dynamically creates numericInputs based on what is selected from a ShinyTree. Then, for each numericInput, I am attempting to create a modal dialog using shiny_icon_link. However, when I click the "i" button, the UI dims as if to display the modal - but it doesn't ever display it. It just gets stuck on dim.

I do this by using lapply inside a renderUI function, in the server section to call bs_attachmodal.

I also do an lapply inside the UI section to call bs_modal.

I haven't pasted any code, because I'm not getting an actual error. I can if necessary.

Have there been any known issues or obvious things that one should do when attempting to create a modal like this?

[ijlyttle]

It would be great if you would provide a reproducible example.

Also, for me, whenever something goes wrong, many times it is because I have created HTML elements with duplicate ID's.

[desaija-lilly]

Thanks for the quick response. I create the IDs through a loop so I can't see where I might make multiple. Here is a trimmed down example. You should be able to run this and replicate the behavior. My goal is to be able to pick the contents of the modal with an HTML file, but for now im just trying to get text in there which corresponds to the created input.

library(shiny)
library(shinydashboard)
library(tidyverse)
library(DT)
library(shinyTree)
library(bsplus)

# SET UP EXAMPLE STRUCTURES

#creates random vector of 5 doubles between 0 and 1.
rand_5 <- function(){
  return(sample.int(100,
                    size=5,
                    replace=TRUE)/100
         )
}

#example df for app
df <- tibble(entrez_gene_id=c(12,35,9,10,500), 
             gene_symbol=c("A1BG", "A2M", "A2MP1", "NAT1", "NAT2"), 
             light_blue=rand_5(), 
             medium_blue=rand_5(), 
             dark_blue=rand_5(), 
             light_red=rand_5(), 
             dark_red=rand_5()
             )

#list to be used as shinytree
tree <- structure(list(reds = structure(list(light_red = "", 
                                             dark_red=""), 
                                        stdisabled=T, 
                                        stopened=T),
                       blues = structure(list(light_blue="", 
                                              medium_blue="", 
                                              dark_blue=""), 
                                         stdisabled=T, 
                                         stopened=T)
                       )
                  )

#modal information
modal_info <- c("light_blue/HELLO LIGHT BLUE", 
                   "medium_blue/HELLO MEDIUM BLUE", 
                   "dark_blue/HELLO DARK BLUE", 
                   "light_red/HELLO LIGHT RED", 
                   "dark_red/HELLO DARK RED")

ui <- dashboardPage(skin="red",
  dashboardHeader(
    title = "testing",
    titleWidth=300
    ),
  dashboardSidebar(
    width=300,
    shinyTree("tree", checkbox=TRUE, search=TRUE, theme="default-dark"),
    uiOutput("selected_analyses"),
    lapply(1:length(modal_info), function(i) {
        this_id <- modal_info[i] %>% str_replace("/.*", "")
        this_body <- modal_info[i] %>% str_replace(".*/", "")
        bs_modal(id = this_id, title = this_id, body = this_body)
      })
  ), 
  dashboardBody(
    fluidPage(
      DT::dataTableOutput("df")
    )
  )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
  output$tree <- renderTree({ tree })

  output$selected_analyses <- renderUI({
    selected <- input$tree %>% get_selected %>% unlist %>% setdiff(names(tree))
    if(length(selected)){
      lapply(1:length(selected), function(i) {
        fluidRow(numericInput(inputId=selected[i], label=selected[i], value=1, min=0, max=1, step=0.1) %>% 
          shinyInput_label_embed(
            shiny_iconlink() %>%
              bs_attach_modal(id_modal = selected[i])
          )
        )
      })
    }
  })

  output$df = DT::renderDataTable({
    selected <- input$tree %>% get_selected %>% unlist %>% setdiff(names(tree))
    if(length(selected)){
      df <- df %>% select(c("entrez_gene_id", "gene_symbol", one_of(selected)))
      datatable(df)
    } else {
      datatable(df[,1:2])
    }
  })

}

# Run the application 
shinyApp(ui = ui, server = server)

[bellma-lilly]

There are two issues that are causing this problem. First, your ids are already used in other places; you might renaming the modals to "light_red_modal" for example. That will allow the modal to show up, but the display is still not quite right.

The second thing is to move the bs_modal calls from the sidebar into the body. Then everything should work as expected. Fully fixed code example below:

library(shiny)
library(shinydashboard)
library(tidyverse)
library(DT)
library(shinyTree)
library(bsplus)

# SET UP EXAMPLE STRUCTURES

#creates random vector of 5 doubles between 0 and 1.
rand_5 <- function(){
  return(sample.int(100,
                    size=5,
                    replace=TRUE)/100
  )
}

#example df for app
df <- tibble(entrez_gene_id=c(12,35,9,10,500), 
             gene_symbol=c("A1BG", "A2M", "A2MP1", "NAT1", "NAT2"), 
             light_blue=rand_5(), 
             medium_blue=rand_5(), 
             dark_blue=rand_5(), 
             light_red=rand_5(), 
             dark_red=rand_5()
)

#list to be used as shinytree
tree <- structure(list(reds = structure(list(light_red = "", 
                                             dark_red=""), 
                                        stdisabled=T, 
                                        stopened=T),
                       blues = structure(list(light_blue="", 
                                              medium_blue="", 
                                              dark_blue=""), 
                                         stdisabled=T, 
                                         stopened=T)
)
)

#modal information
modal_info <- c("light_blue/HELLO LIGHT BLUE", 
                "medium_blue/HELLO MEDIUM BLUE", 
                "dark_blue/HELLO DARK BLUE", 
                "light_red/HELLO LIGHT RED", 
                "dark_red/HELLO DARK RED")

ui <- dashboardPage(skin="red",

                    dashboardHeader(
                      title = "testing",
                      titleWidth=300
                    ),
                    dashboardSidebar(
                      width=300,
                      shinyTree("tree", checkbox=TRUE, search=TRUE, theme="default-dark"),
                      uiOutput("selected_analyses")

                    ), 
                    dashboardBody(
                      fluidPage(
                        DT::dataTableOutput("df"),
                         ###Move modal creation to here
                        lapply(1:length(modal_info), function(i) {
                          this_id <- modal_info[i] %>% str_replace("/.*", "")
                          this_body <- modal_info[i] %>% str_replace(".*/", "")
                          ###ADD _modal here
                          bs_modal(id = paste0(this_id,"_modal"), title = this_id, body = this_body)
                        })
                      )
                    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {
  output$tree <- renderTree({ tree })

  output$selected_analyses <- renderUI({
    selected <- input$tree %>% get_selected %>% unlist %>% setdiff(names(tree))
    if(length(selected)){
      print(selected)
      lapply(1:length(selected), function(i) {
        fluidRow(numericInput(inputId=selected[i], label=selected[i], value=1, min=0, max=1, step=0.1) %>% 
                   shinyInput_label_embed(
                     shiny_iconlink() %>%
                       ###ADD _modal here
                       bs_attach_modal(id_modal = paste0(selected[i],"_modal"))
                   )
        )
      })
    }
  })

  output$df = DT::renderDataTable({
    selected <- input$tree %>% get_selected %>% unlist %>% setdiff(names(tree))
    if(length(selected)){
      df <- df %>% select(c("entrez_gene_id", "gene_symbol", one_of(selected)))
      datatable(df)
    } else {
      datatable(df[,1:2])
    }
  })

}

# Run the application 
shinyApp(ui = ui, server = server)

[desaija-lilly]

Yep this works perfectly. Thank you!

[ijlyttle]

Thanks @bellma-lilly! I am very relieved that this example is working!