动态标签与R-Shiny应用程序使用相同的输出功能

Question

目标：我正在进行一个生物信息学项目。我目前正在尝试实现动态创建tabPanels的R代码(除了数据输出之外，它们本质上是碳拷贝)。

实现：经过一些研究，我实现了这个解决方案。它在某种程度上起作用(我正在"碳复制"的面板是创建的)，但我需要的数据无法显示。

问题：我确信我显示数据的方式很好。问题是，我不能使用相同的输出函数来显示这里看到的数据。让我来了解一下代码。。。

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")
)

我使用uiOutput在服务器端动态生成选项卡。。。。

服务器.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)
})
}
)

解释：现在我意识到这里有很多东西要看。。但我的问题存在于输出$change_tabs(这是最后一个函数)中，它调用fetch_tabs()。获取选项卡使用输入$gene(通过选择输入的基因列表(multiple=TRUE))动态创建一组由用户选择的每个基因2个选项卡。

发生了什么：因此，如果用户选择2个基因，则会创建4个选项卡。用5个基因创建了10个标签。。。等等。。。除了数据之外，每个选项卡都完全相同。

路障：但是。。。对于每个选项卡，我都试图为我想要显示的数据使用相同的输出Id(因为它们完全相同)(textOutput(outputId="file"))。正如上面在第二个链接中所解释的，这根本不起作用，因为HTML。

问题：我尝试过研究几种解决方案，但我宁愿不必实施此解决方案。我不想重写那么多代码。有没有什么方法可以添加一个反应函数或观测器函数来包装或修复我的输出$file函数？或者有没有办法在do.call(tabsetPanel，myTabs)之后将信息添加到我的选项卡中？我这样想对了吗？

我知道我的代码没有得到很好的评论，所以我提前道歉。请随时在评论中批评我的编码风格，即使你没有解决方案。求你了，谢谢你！

Answer 1

我提出了一个非常粗略的答案，目前有效。。。

以下是@BigDataScientist 的答案

我的问题与BigDataScientist的答案：

我不能动态地将数据传递到输出。输出函数只有在需要时才会被解释。。。因此，如果我想将您创建的for循环迭代器(iter)传递到动态创建的输出中，那么我将无法做到这一点。它只能获取静态数据

我的解决方案：
我最终利用了我在这里找到的sys.calls()解决方案，以便将函数的名称作为字符串。函数的名称包含了我需要的信息(在本例中是一个数字)。

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

我认为你是这种行为的受害者。尝试：

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

就像Joe在我链接的Github问题的第一个回复中建议的那样。只有当你使用for循环时，这才是必要的。lapply已经将el作为一个参数，所以您可以免费获得这种"动态评估"好处(因为没有更好的名称)。

为了便于阅读，我将在这里引用Joe的大部分答案：

你是我采访过的useR中第二个被R中的这种行为所困扰的人。这是因为for循环的所有迭代都共享对el的相同引用。因此，当任何创建的反应式表达式执行时，他们使用的是el的最终值。

你可以通过以下方式来解决这个问题：1)使用lapply而不是for loop；由于每个迭代都作为自己的函数调用执行，因此它获得了自己对el的引用；或2)使用for循环，但在其中引入局部({…})，并在其中创建一个局部变量，其值被分配给反应器之外的el。