Modal window opens on change in selectInput. Needs to only open when an actionLink is clicked.

[dmc]

I have a Shiny App that is causing me a problem. What I would like it to do is dynamically create some actionLinks that when clicked, trigger a modal window to open. The number of action links will vary depending on the value of a selectInput. The selectInput allows the user to choose a year. For example, the number of action links in 2018 may be 1 and the number of action links in 2016 may be 3.

The reprex code that I have pasted here, does create different numbers of actionLinks based on the data. The problem that I run into is that if I click on an actionLink (and subsequently close it) and THEN change the year, a new modal window opens up. I would like a modal window to open only after another actionLink is clicked.

How do I keep the modal window from opening without the actionLink being clicked?

The App.R code is below:

library(shiny)
ActionLinkIndex <- NULL
YearCount <- 0
firstCall <- TRUE
savedYear <- 2018

# Define UI for application 
ui <- fluidPage(
   
  # Application title
  titlePanel("Test Application"),
  
  sidebarLayout(
    sidebarPanel(
      radioButtons("graph", "Select Buttons:",
                   c("Test1", 
                     "Test2")
      )
    ),
    mainPanel(
      uiOutput("theUI")
    )
  )
)

# Define server logic required 
server <- function(input, output) {
   
  library(tidyr)
  library(dplyr)
  
  ########################################################
  # Data Creation                                        #
  ########################################################
  
  gReportTable2016 <- data.frame(NAME=c("A", "B", "C"), CH=c(0,1,1), CO=c(0,0,0), M=c(1,0,1))
  gReportTable2018 <- data.frame(NAME=c("ABC"), CH=0, CO=0, M=1)
  gReportTable2017 <- data.frame(NAME=c("DEF", "GHI"), CH=c(0,1), CO=c(0,0), M=c(1,1))
  
  ########################################################
  # Observe Events                                       #
  ########################################################
  
  observeEvent(input$theYear, {
    cat("********************** Entered observeEvent(input$theYear) ********************\n")
    savedYear <- input$theYear
    if(input$theYear=="2016") theTable <<- gReportTable2016  
    if(input$theYear=="2017") theTable <<- gReportTable2017 
    if(input$theYear=="2018") theTable <<- gReportTable2018
    if(firstCall==TRUE){
      firstCall <<- FALSE
    } else{
      for(i in ActionLinkIndex:1){
        cat("     ******************** Destroying", paste0("AL", i), "**********************\n")
        t.observers.new[[i]]$destroy()
      }      
    }
    ActionLinkIndex <<- NULL
    
    tempCount <- YearCount + 1
    assign("YearCount", tempCount, pos=1)
    cat("********************** Leaving observeEvent(input$theYear) ********************\n")
  }, ignoreInit=TRUE)
  create.observers.new <- function(number.of.observers, html.ID, in.data){
    trigger.modal.debug <- function(){
      showModal(modalDialog(
        renderUI({
          tagList(
            h4("Print something")
            
          )
        }),
        title = "Blank Modal Window",
        easyClose = TRUE
      ))}
    number.of.observers <- dim(theTable)[[1]]
    IDs <- seq_len(number.of.observers)  
    t.out <- lapply(IDs, function(i){
      cat("Creating observer:", paste0("AL", i), "\n")
      observeEvent(input[[paste0(html.ID, i)]], trigger.modal.debug(), ignoreNULL=TRUE, suspended=FALSE)
    })
    t.out
  }
  
  ########################################################
  # Create UIs                                           #
  ########################################################
  output$theYearList <- renderUI({
    first.year <- 2016
    last.year <- 2018
    year.list <- c(first.year:last.year)
    t.out <- selectInput("theYear", "Year:", 
                         year.list, selected = savedYear 
    )
    t.out   
  })
  output$testReport <- renderUI({
    f.NewRow <- function(the.data){
      the.rows <- c(1:dim(the.data)[[1]])
      t.out <- vector("list", length(the.rows))
      t.out <- lapply(the.rows, function(i){
        t.out[[i]] <- fluidRow(
          f.details(the.data[i,])
        )
      })
      t.out
    }
    f.details <- function(data){
      setValue <- function(data, index){
        index <- index + 1
        t.out <- list(actionLink(paste0("AL", index), label = paste0("Name:", data$NAME)))
        
        ActionLinkIndex <<- index
        t.out
      }
      
      if(is.null(ActionLinkIndex))
        ActionLinkIndex <<- 0

      t.out <- setValue(data, ActionLinkIndex)
      
      t.out
    }
    
    if(!is.null(input$theYear)){
      t.out <- list(fluidRow(
        f.NewRow(theTable) 
      ))
      t.1 <- create.observers.new(ActionLinkIndex, "AL", theTable) #the.data)
      t.observers.new <<- t.1
    } else t.out <- NULL
    t.out
  })
  output$theUI <- renderUI({
    tagList(
      uiOutput("theYearList"),
      uiOutput("testReport")
    )
  })
  
}

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

[pieterjanvc]

Hi,

It's always tricky with all these reactive environments, especially if you're generating them on the go

The reason your modal popped up is because when you select a new year, your code creates the new links and the creation of the links will trigger them unless you force them not too like this:

t.out <- lapply(IDs, function(i){
            cat("Creating observer:", paste0("AL", i), "\n")
            observeEvent(input[[paste0(html.ID, i)]], trigger.modal.debug(), ignoreNULL=TRUE, suspended=FALSE, ignoreInit = T)
        })

By setting ignoreInit = T you do not trigger the modal when new links are created.

Hope this solved it!
PJ