R-Shiny应用程序的动态选项卡使用相同的输出功能

Question

Goal: I'm working on a bioinformatics project. I'm currently trying to implement R code that dynamically creates tabPanels (they are essentially carbon copies except for the data output).

Implementation: After doing some research I implemented this solution. It works in a way (the panels that I'm "carbon copying" are created), but the data that I need cannot be displayed.

Problem: I'm sure that the way I'm displaying my data is fine. The problem is that I can't use the same output function to display the data as seen here . So let me get to the code...

ui.R

library(shiny)
library(shinythemes)
library(dict)
library(DT)
...# Irrelevant functions removed #...

geneinfo <- read.table(file = "~/App/final_gene_info.csv",
                   header = TRUE,
                   sep = ",",
                   na.strings = "N/A",
                   as.is = c(1,2,3,4,5,6,7))


ui <- navbarPage(inverse = TRUE, "GENE PROJECT",
                theme = shinytheme("cerulean"),
                 tabPanel("Home",
                          #shinythemes::themeSelector(),
                          fluidPage(
                            includeHTML("home.html")
                            )),
                  tabPanel("Gene Info",
                          h2('Detailed Gene Information'),
                          DT::dataTableOutput('table')),
                 tabPanel("File Viewer",
                          sidebarLayout(
                            sidebarPanel(
                              selectizeInput(inputId = "gene", label = "Choose a Gene", choice = genes, multiple = TRUE),
                              selectInput(inputId = "organism", label = "Choose an Organism", choice = orgs),
                              selectInput(inputId = "attribute", label = "Choose an Other", choice = attributes),
                              width = 2),
                            mainPanel(
                              uiOutput('change_tabs'),
                            width = 10))),
                 tabPanel("Alignment")

)

I'm using uiOutput to generate tabs dynamically on the server side....

server.R

server <- function (input, output, session) {

  # Generate proper files from user input
  fetch_files <- function(){
    python <- p('LIB', 'shinylookup.py', python=TRUE)
    system(sprintf('%s %s %s', python, toString(genie), input$organism), wait = TRUE)
    print('Done with Python file generation.')

  # Fetch a temporary file for data output

  fetch_temp <- function(){

    if(input$attribute != 'Features'){
      if(input$attribute != 'Annotations'){
        chosen <- toString(attribute_dict[[input$attribute]])

      }
      else{
        chosen <- toString(input$sel)
        extension <<- '.anno'
      }
    }
    else{
      chosen <- toString(input$sel)
      extension <<- '.feat'
    }
    count = 0
    oneline = ''
    f <- paste(toString(genie), toString(input$organism), sep = '_')
    f <- paste(f, extension, sep = '')

    # Writes a temporary file to display output to the UI

    target <- p('_DATA', f)
    d <- dict_fetch(target)
    temp_file <- tempfile("temp_file", p('_DATA', ''), fileext = '.txt')
    write('', file=temp_file)
    vectorofchar <- strsplit(toString(d[[chosen]]), '')[[1]]
    for (item in vectorofchar){
      count = count + 1
      oneline = paste(oneline, item, sep = '')

      # Only 60 characters per line (Find a better solution)
      if (count == 60){ 
        write(toString(oneline), file=temp_file, append=TRUE)
        oneline = ''
        count = 0
      }
    }
    write(toString(oneline), file=temp_file, append=TRUE)
    return(temp_file)
  }

  # Get the tabs based on the number of genes selected in the UI
  fetch_tabs <- function(Tabs, OId, s = NULL){
    count = 0

    # Add a select input or nothing at all based on user input
    if(is.null(s)==FALSE){
      selection <- select(s)
      x <- selectInput(inputId = 'sel', label = "Choose an Annotation:", choices = selection$keys())
    }
    else
      x <- ''

    for(gene in input$gene){
      if(count==0){myTabs = character()}
      count = count + 1
      genie <<- gene
      fetch_files()
      file_tab <- lapply(sprintf('File for %s', gene), tabPanel
                                          fluidRow(
                                            titlePanel(sprintf("File for %s:", gene)),
                                            column(5,
                                                   pre(textOutput(outputId = "file")),offset = 0))
                             )

      addTabs <- c(file_tab, lapply(sprintf('%s for %s',paste('Specific', Tabs), gene), tabPanel,
                                       fluidRow(
                                           x,
                                         titlePanel(sprintf("Attribute for %s:", gene)),
                                         column(5,
                                                pre(textOutput(outputId = OId), offset = 0)))
                                       ))
      # Append additional tabs every iteration
      myTabs <- c(myTabs, addTabs)
    }
    return(myTabs)
  }
  # Select the proper file and return a dictionary for selectInput
  select <- function(ext, fil=FALSE){
    f <- paste(toString(genie), toString(input$organism), sep = '_')
    f <- paste(f, ext, sep = '')
    f <- p('_DATA', f)
    if(fil==FALSE){
      return(dict_fetch(f))
    }
    else if(fil==TRUE){
      return(toString(f))
    }
  }

  # Output gene info table
  output$table <- DT::renderDataTable(
    geneinfo,
    filter = 'top',
    escape = FALSE,
    options = list(autoWidth = TRUE,
                   options = list(pageLength = 10),
                   columnDefs = list(list(width = '600px', targets = c(6))))
  )
    observe({

      x <- geneinfo[input$table_rows_all, 2]
      if (is.null(x))
        x <- genes
      updateSelectizeInput(session, 'gene', choices = x)
    })


  # Output for the File tab
  output$file <- renderText({
    extension <<- '.gbk'
    f <- select(extension, f=TRUE)
    includeText(f)
  })
  # Output for attributes with ony one property
  output$attributes <- renderText({
    extension <<- '.kv'
    f <- fetch_temp()
    includeText(f)
  })
  # Output for attributes with multiple properties (features, annotations)
  output$sub <- renderText({
    f <- fetch_temp()
    includeText(f)
  })

  # Input that creates tabs and selectors for more input
  output$change_tabs <- renderUI({

    # Fetch all the appropriate files for output
    Tabs = input$attribute

    if(input$attribute == 'Annotations'){
      extension <<- '.anno'
      OId = 'sub'
      s <- extension
    }
    else if(input$attribute == 'Features'){
      extension <<- '.feat'
      OId = 'sub'
      s <- extension
    }
    else{
      OId = 'attributes'
      s <- NULL
    }
    myTabs <- fetch_tabs(Tabs, OId, s = s)
    do.call(tabsetPanel, myTabs)
  })
}
)

Explanation: Now I'm aware that there's a lot to look at here.. But my problem exists within output$change_tabs (it's the last function), which calls fetch_tabs() . Fetch tabs uses the input$gene (a list of genes via selectizeInput(multiple=TRUE) ) to dynamically create a set of 2 tabs per gene selected by the user.

What's Happening: So if the user selects 2 genes then 4 tabs are created. With 5 genes 10 tabs are created... And so on and so forth... Each tab is EXACTLY THE SAME, except for the data.

Roadblocks: BUT... for each tab I'm trying to use the same output Id (since they are EXACTLY THE SAME) for the data that I want to display ( textOutput(outputId = "file") ). As explained above in the second link, this simply does not work because HTML.

Questions: I've tried researching several solutions, but I would rather not have to implement this solution. I don't want to have to rewrite so much code. Is there any way I can add a reactive or observer function that can wrap or fix my output$file function? Or is there a way for me to add information to my tabs after the do.call(tabsetPanel, myTabs) ? Am I thinking about this the right way?

I'm aware that my code isn't commented very well so I apologize in advance. Please feel free to critique my coding style in the comments, even if you don't have a solution. Please and thank you!

Answer 1

I've come up with a very VERY crude answer that will work for now...

Here is the answer from @BigDataScientist

My Issue with BigDataScientist's Answer:

I can't dynamically pass data to the outputs. The output functions are not interpreted until they are needed... So if I wanted to pass the for loop iterator that you created (iter) into the dynamically created outputs, then I wouldn't be able to do that. It can only take static data

My Solution:
I end up taking advantage of sys.calls() solution I found here in order to get the name of the function as a string. The name of the function has the info I need (in this case a number).

library(shiny)
library(shinythemes)
myTabs <<- list()
conv <- function(v1) {
  deparse(substitute(v1))
}
ui <- navbarPage(inverse = TRUE, "GENE PROJECT",
                 theme = shinytheme("cerulean"),
                 tabPanel("Gene Info",

                          sidebarLayout(
                            sidebarPanel(
                              sliderInput("bins",
                                          "Number of bins:",
                                          min = 1,
                                          max = 5,
                                          value = 3)
                            ),

                            # Show a plot of the generated distribution
                            mainPanel(
                              uiOutput('changeTab')
                            )
                          )
                 )
)


server <- function(input, output) {
  observe({
    b <<- input$bins
    myTabs <<- list()
    # Dynamically Create output functions
    # Dynamically Create formatted tabs
    # Dynamically Render the tabs with renderUI
    for(iter in 1:b){
      x <<- iter
      output[[sprintf("tab%s", iter)]] <- renderText({
        temp <- deparse(sys.calls()[[sys.nframe()-3]])
        x <- gsub('\\D','',temp)
        x <- as.numeric(x)
        f <- sprintf('file%s.txt', x)
        includeText(f)
      })
      addTabs <<- lapply(sprintf('Tab %s', iter), tabPanel,
                        fluidRow(
                          titlePanel(sprintf("Tabble %s:", iter)),
                          column(5,
                                 pre(textOutput(outputId = sprintf('%s%s','tab', iter))))))
      myTabs <<- c(myTabs, addTabs)
    }
    myTabs <<- c(myTabs, selected = sprintf('Tab %s', x))

    output$changeTab <- renderUI({
      do.call(tabsetPanel, myTabs)

    })
  })

}


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

Answer 2

I think your being a victim of this behavior . Try:

for (el in whatever) {
  local({
    thisEl <- el
    ...
 })
} 

like Joe suggests in the first reply to the Github issue I linked to. This is only necessary if you're using a for loop. lapply already takes el as an argument, so you get this "dynamic evaluation" benefit (for lack of a better name) for free.

For readability, I'm going to quote most of Joe's answer here:

You're the second person at useR that I talked to that was bitten by this behavior in R. It's because all the iterations of the for loop share the same reference to el. So when any of the created reactive expressions execute, they're using whatever the final value of el was.

You can fix this either by 1) using lapply instead of a for loop; since each iteration executes as its own function call, it gets its own reference to el; or 2) using a for loop but introducing a local({...}) inside of there, and creating a local variable in there whose value is assigned to el outside of the reactive.