attempting bs_modal and bs_attach_modal inside renderUI about bsplus

[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]

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)

[ijlyttle]

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