Shiny app with dynamic number of datatables

makis23 · November 2, 2017, 5:31am

Hi i want to create a shiny app which will display the datatables all together (if i choose) based on a sliderinput. I displayed two as an example but as you can see they are static and not connected with the slider, I also included an example with plots in my app to show what exactly i want to achieve but im not sure how to do it with datatables.

ui.r

library(rhandsontable)
library(magrittr)
library(DT)
library(data.table)
library(kableExtra)
library(shinyBS)

shinyUI(pageWithSidebar(

  headerPanel("Dynamic number of plots"),

  sidebarPanel(
    sliderInput("n", "Number of plots", value=1, min=1, max=5),
    uiOutput("sli")
  ),

  mainPanel(
    # This is the dynamic UI for the plots
    uiOutput("plots"),

    dataTableOutput("hist1"),
    dataTableOutput("hist2")

  )
))

server.r

max_plots <- 5

shinyServer(function(input, output) {

#CORRECT PART FOR EXAMPLE

   # Insert the right number of plot output objects into the web page
  output$plots <- renderUI({
    plot_output_list <- lapply(1:input$n, function(i) {
      plotname <- paste("plot", i, sep="")
      plotOutput(plotname, height = 280, width = 250)
    })

    # Convert the list to a tagList - this is necessary for the list of items
    # to display properly.
    do.call(tagList, plot_output_list)
  })

  # Call renderPlot for each one. Plots are only actually generated when they
  # are visible on the web page.
  for (i in 1:max_plots) {
    # Need local so that each item gets its own number. Without it, the value
    # of i in the renderPlot() will be the same across all instances, because
    # of when the expression is evaluated.
    local({
      my_i <- i
      plotname <- paste("plot", my_i, sep="")

      output[[plotname]] <- renderPlot({
        plot(1:my_i, 1:my_i,
             xlim = c(1, max_plots),
             ylim = c(1, max_plots),
             main = paste("1:", my_i, ".  n is ", input$n, sep = "")
        )
      })
    })
  }

  ### PART NEEDS FIXING

  output$sli <- renderUI({
    sliderInput("n", "Number of tables", value=1, min=1,step = 1, max=2)
  })

  DF = data.frame(
    Variables = c("Revenue Growth", "Change in Gross Margin", "Change in Operating Margin"),
    Lower.Bound = rep("", 3),
    Upper.Bound = rep("", 3),
    row.names = NULL,
    stringsAsFactors = FALSE
  )
  #function simulating  history table
  make_history<-function() {
    prev_rev_lb = sprintf( "%.1f%%", -5 )
    prev_rev_ub = sprintf( "%.1f%%", 10 )
    prev_gm_lb = format( -1, nsmall = 1 )
    prev_gm_ub = format( 3, nsmall = 1 )
    prev_om_lb = format( -2, nsmall = 1 )
    prev_om_ub = format( 5, nsmall = 1 )

    tbl3 <- data.table(Variables = c("Revenue Growth", "Change in Gross Margin", "Change in Operating Margin"),
                       `Lower Bound` = c( prev_rev_lb, prev_gm_lb, prev_om_lb ),
                       `Upper Bound` = c( prev_rev_ub, prev_gm_ub, prev_om_ub )
    )

    tbl3
  }

  History <- reactiveValues(DF1 = data.frame(), DF2 = data.frame(), DF3 = data.frame())

  showHistory<-function(DF2, DF3) {
    History$DF2 <- DF2
    History$DF3 <- DF3

    output$hist1<-renderDataTable({
      if (nrow(History$DF2)!=0) {
        History$DF2
      }
      # FIXME: else?
    }, selection="none", options=list(paging=F, ordering=F, searching=F, bLengthChange=F, bFilter=F,bInfo=F)
    )

    output$hist2<-renderDataTable({
      if(nrow(History$DF3)!=0) {
        History$DF3
      } 
      # FIXME: else?
    }, selection="none", options=list(paging=F, ordering=F, searching=F, bLengthChange=F, bFilter=F,bInfo=F)
    )    

  }
  # VV: TODO: get history from the DB
  df1 <- make_history()
  df2 <- make_history()  

  showHistory(df1, df2)


})

barbara · November 2, 2017, 9:50pm

This should work:

library(shiny)
library(DT)

maxTables <- 5

ui <- fluidPage(
  sidebarPanel(
    sliderInput("n", "Number of DTs", value=1, min=1, max=maxTables)
  ),
  mainPanel(
    uiOutput("dt")
  )
)

server <- function(input, output, session) {
  output$dt <- renderUI({
    lapply(as.list(seq_len(input$n)), function(i) {
      id <- paste0("dt", i)
      DT::dataTableOutput(id)
    })
  })
    
  for (i in seq_len(maxTables)) {
    id <- paste0("dt", i)
    output[[id]] <- DT::renderDataTable(iris)
  }
}

shinyApp(ui, server)

And here's a much more elaborate example (adapted from something else) that uses a button + insertUI, so that each table is independent from the previous ones (this also means that they don't all redraw whenever the input changes, like in the example above):

library(shiny)
ui <- fluidPage(
  textInput("divID", "Enter an ID for the custom area:", ""),
  helpText("Leave the text input blank for automatically unique IDs."),
  actionButton("isrt", "Add a datatable"), 
  tags$div(id = "placeholder")
)

server <- function(input, output, session) {
  rv <- reactiveValues()
  
  # take a dependency on `isrt` button
  observeEvent(input$isrt, {
    
    # handle the case when user does not provide ID
    divID <- if (input$divID == "") gsub("\\.", "", format(Sys.time(), "%H%M%OS3")) 
    else input$divID
    dtID <- paste0(divID, "DT")
    btnID <- paste0(divID, "rmv")
    
    # only create button if there is none
    if (is.null(rv[[divID]])) {
      
      insertUI(
        selector = "#placeholder",
        ui = tags$div(id = divID,
                      actionButton(btnID, "Remove this table", class = "pull-right btn btn-danger"),
                      DT::dataTableOutput(dtID),
                      hr()
        )
      )
      
      output[[dtID]] <- DT::renderDataTable(head(iris))
      
      # make a note of the ID of this section, so that it is not repeated accidentally
      rv[[divID]] <- TRUE
      
      # create a listener on the newly-created button that will
      # remove it from the app when clicked
      observeEvent(input[[btnID]], {
        removeUI(selector = paste0("#", divID))
        
        rv[[divID]] <- NULL
        
      }, ignoreInit = TRUE, once = TRUE)
      
      # otherwise, print a message to the console
    } else {
      message("The button has already been created!")
    }
  })
}

shinyApp(ui = ui, server = server)

makis23 · November 2, 2017, 10:25pm

Great answers!! maybe you can look at an other alternative.. i have this code sample which works fine and produces 4 datatables.

showHistory <- function(DF2, DF3, DF4, DF5) {
if (!is.null(DF2) && nrow(DF2) != 0) {
output$hist1 <- renderDataTable({DF2},
selection="none", options=list(paging=F, ordering=F,
searching=F, bLengthChange=F,
bFilter=F,bInfo=F)
)
}

if(!is.null(DF3) && nrow(DF3)!=0) {
output$hist2 <- renderDataTable({DF3},
selection="none", options=list(paging=F, ordering=F,
searching=F, bLengthChange=F,
bFilter=F,bInfo=F)
)
}
if(!is.null(DF4) && nrow(DF4)!=0) {
output$hist3 <- renderDataTable({DF4},
                                selection="none", options=list(paging=F, ordering=F,
                                                               searching=F, bLengthChange=F,
                                                               bFilter=F,bInfo=F)
)
}
if(!is.null(DF5) && nrow(DF5)!=0) {
output$hist4 <- renderDataTable({DF5},
                                selection="none", options=list(paging=F, ordering=F,
                                                               searching=F, bLengthChange=F,
                                                               bFilter=F,bInfo=F)
)
}

} # end of showHistory()

Get est history from the DB

#est <- reactive({load_history('Bill Nye', 'ai001161.01')})

est <- reactive({load_history(input$expert, input$company)})

est_list <- reactive({
est2 <- est()
#cat("class(est2)=", class(est2), "\n")
#cat("dim(est2)=", dim(est2), "\n")
#print(est2)
split(est2, est2$est_id)
})

Dummy hist for testing

#df1 <- make_history()
#df2 <- make_history()
#df_list <- list(df1, df2)

get_measure_columns <- function(df) {
df2 <- df[, c('measure_name', 'value_lower', 'value_upper')]
colnames(df2) <- c('Variable', 'Lower Bound', 'Upper Bound')

df2
}

reactive({
el <- est_list()
#cat("el=\n")
#print(el)

df1 <- NULL
df2 <- NULL

if (length(el) >= 1) {
df1 <- get_measure_columns(el[[1]])
}

if (length(el) >= 2) {
df2 <- get_measure_columns(el[[2]])
}

if (length(el) >= 3) {
df3 <- get_measure_columns(el[[3]])
}
if (length(el) >=4) {
df4 <- get_measure_columns(el[[4]])
}

showHistory(df1, df2, df3, df4)
})


> #### Your past Estimates 
> Estimate from 02/07/2017
> ```{r}
> dataTableOutput("hist1") 
> br()
> ```
> 
> 
> Estimate from 01/05/2017
> ```{r}
> dataTableOutput("hist2")
> br()
> ```
> 
> Estimate from 12/03/2016
> ```{r}
> dataTableOutput("hist3")
> br()
> ```
> 
> Estimate from 11/09/2016
> ```{r}
> dataTableOutput("hist4")
> br()
> ```
but when i replace the if statements with for loops it does not produce everything but does not display an error too.

> showHistory <- function(DF2, DF3, DF4, DF5) {
>   for(i in 2:5){
>   if (!is.null(DF[i]) && nrow(DF[i]) != 0) {
>     output$hist[i-1] <- DT::renderDataTable({
>       DT:: datatable (DF[i],
>                                     selection="none", options=list(paging=F, ordering=F,
>                                                                    searching=F, bLengthChange=F,
>                                                                    bFilter=F,bInfo=F)
>     )
>   })}}}
>   
>   
>   
>  # end of showHistory()
> 
> # Get est history from the DB
> 
> #est <- reactive({load_history('Bill Nye', 'ai001161.01')})
> 
> est <- reactive({load_history(input$expert, input$company)})
> 
> est_list <- reactive({
>   est2 <- est()
>   #cat("class(est2)=", class(est2), "\n")
>   #cat("dim(est2)=", dim(est2), "\n")
>   #print(est2)
>   split(est2, est2$est_id)
> })
> 
> # Dummy hist for testing
> #df1 <- make_history()
> #df2 <- make_history()  
> #df_list <- list(df1, df2)
> 
> get_measure_columns <- function(df) {
>   df2 <- df[, c('measure_name', 'value_lower', 'value_upper')]
>   colnames(df2) <- c('Variable', 'Lower Bound', 'Upper Bound')
> 
>   df2
> }
> for(i in 1:4){
> reactive({
>   el <- est_list()
>   #cat("el=\n")
>   #print(el)
> 
>   df1 <- NULL
>   df2 <- NULL
> 
>   if (length(el) >= i) {
>     df[i] <- get_measure_columns(el[[i]])
>   }
> 
> showHistory(
>     
>     df1,df2,df3,df4)
>     
>   
> })}
> 
> 
> 
> ```
> 
> #### Your past Estimates 
> Estimate from 02/07/2017
> ```{r}
> DT::dataTableOutput("hist1") 
> br()
> ```
> 
> 
> Estimate from 01/05/2017
> ```{r}
> DT::dataTableOutput("hist2")
> br()
> ```
> 
> Estimate from 12/03/2016
> ```{r}
> DT::dataTableOutput("hist3")
> br()
> ```
> 
> Estimate from 11/09/2016
> ```{r}
> DT::dataTableOutput("hist4")
> br()

Do you see something wrong in my for logic??

makis23 · November 3, 2017, 12:32pm

Could you implement your first solution with a for loop from 1 to 10 instead of sliderinput?

PedramHash · December 18, 2017, 12:09pm

In the first version of your code there is no way for me to print the two different tables, all the tables are the same and the last table that I initialize is inserted.

table <- NULL
table[['tab1']] <- iris[1:2,]
table[['tab2']] <- iris[1:4,]
table[['tab3']] <- iris[1:6,]
table[['tab4']] <- iris[1:8,]
        
for (i in seq_len(4)) {
  id <- paste0("dt", i)
  output[[id]] <- DT::renderDataTable(table[[i]])
}

barbara · December 18, 2017, 2:39pm

I suspect this is just lazy evaluation (you are using the iter variable i inside a loop, without forcing it first). Put this line inside your for loop and see if it fixes it:

force(i)

PedramHash · December 19, 2017, 8:17am

Thanks, but still not working. and by the way I don't understand why I should use force. I've beed using these syntaxes normally and they always worked.

    table <- NULL
    table[['tab1']] <- iris[1:2,]
    table[['tab2']] <- iris[1:4,]
    table[['tab3']] <- iris[1:6,]
    table[['tab4']] <- iris[1:8,]

    for (i in seq_len(4)) {
      
      force(i)
      id <- paste0("dt", i)
      output[[id]] <- DT::renderDataTable(table[[i]])
    }

greg · December 20, 2017, 5:44am

Beware of using closures in for loops! The expressions passed into render functions are captured in closures and not evaluated immediately (same goes for reactive and observe). Issues arise when these expressions reference loop variables, which are in the same scope as the for loop and not local to each iteration.

So by the time any of the output expressions are evaluated, the loop has already ended with i = 4, and each table[[i]] expression evaluates to table[[4]].

Here are a few ways around this using a simplified version of your example and faked out Shiny output / renderDataTable for demo purposes.

output <- new.env()
renderTable <- function(expr) {
  function() expr
}

table <- list(
  iris[1, 1:2],
  iris[2, 1:2],
  iris[3, 1:2],
  iris[4, 1:2]
)

# The original problem - each output turns out to be table[[4]]

for (i in seq_len(4)) {
  id <- paste0("dt", i)
  output[[id]] <- renderTable(table[[i]])
}

for (func in as.list(output)) print(func())
#   Sepal.Length Sepal.Width
# 4          4.6         3.1
#   Sepal.Length Sepal.Width
# 4          4.6         3.1
#   Sepal.Length Sepal.Width
# 4          4.6         3.1
#   Sepal.Length Sepal.Width
# 4          4.6         3.1

Create a local scope for each loop iteration

Each table[[i]] references an i bound in a new environment instead of the actual loop variable. This is also demonstrated in @makis23's example.

for (i in seq_len(4)) {
  local({
    i <- i
    id <- paste0("dt", i)
    output[[id]] <- renderTable(table[[i]])
  })
}

for (func in as.list(output)) print(func())
#   Sepal.Length Sepal.Width
# 1          5.1         3.5
#   Sepal.Length Sepal.Width
# 2          4.9           3
#   Sepal.Length Sepal.Width
# 3          4.7         3.2
#   Sepal.Length Sepal.Width
# 4          4.6         3.1

Call the render function in a separate function

Each table[[i]] references an i created in a function environment for each iteration instead of the actual loop variable. But now you also have to deal with function arguments being lazy in R. force is used to force evaluation of function args.

renderMyTable <- function(i) {
  force(i)
  renderTable(table[[i]])
}

for (i in seq_len(4)) {
    id <- paste0("dt", i)
    output[[id]] <- renderMyTable(i)
}

for (func in as.list(output)) print(func())
#   Sepal.Length Sepal.Width
# 1          5.1         3.5
#   Sepal.Length Sepal.Width
# 2          4.9           3
#   Sepal.Length Sepal.Width
# 3          4.7         3.2
#   Sepal.Length Sepal.Width
# 4          4.6         3.1

Or maybe more naturally, without having to explicitly force argument evaluation:

setTableOutput <- function(i) {
  id <- paste0("dt", i)
  output[[id]] <- renderTable(table[[i]])
}

for (i in seq_len(4)) {
  setTableOutput(i)
}

for (func in as.list(output)) print(func())
#   Sepal.Length Sepal.Width
# 1          5.1         3.5
#   Sepal.Length Sepal.Width
# 2          4.9           3
#   Sepal.Length Sepal.Width
# 3          4.7         3.2
#   Sepal.Length Sepal.Width
# 4          4.6         3.1

Use `apply` (or similar) instead

This is the hakuna matata solution where you don't have to stress out about scoping issues or lazy evaluation (as of R 3.2.0).

lapply(seq_len(4), function(i) {
  id <- paste0("dt", i)
  output[[id]] <- renderTable(table[[i]])
})

for (func in as.list(output)) print(func())
#   Sepal.Length Sepal.Width
# 1          5.1         3.5
#   Sepal.Length Sepal.Width
# 2          4.9           3
#   Sepal.Length Sepal.Width
# 3          4.7         3.2
#   Sepal.Length Sepal.Width
# 4          4.6         3.1

Shiny app with dynamic number of datatables

Get est history from the DB

Dummy hist for testing

Create a local scope for each loop iteration

Call the render function in a separate function

Use apply (or similar) instead

Use `apply` (or similar) instead