在 Shiny 中从一个 DataTable 到另一个 DataTable 的超链接

Question

我有一个由两个页面组成的 Shiny 应用程序：

• 第 1 页显示带有摘要信息的 DataTable (ensembles)。
• 第 2 页显示特定组合的详细定价信息 (items)，这是可选的。

当用户点击第 1 页上的一行时，我希望他们被带到第 2 页，并选择相应的整体。

以下代码创建了 Shiny 应用和两个页面，但需要用户手动切换页面并输入集合号。

app.R

library(shiny)

## Create item pricing data
set.seed(1234)
init_items = function() {
  item.id=1:1000
  ensemble.id=rep(1:100,each=10)
  cost=round(runif(1000,10,100), 2)
  profit=round(cost*runif(1000,0.01,0.15), 2)
  price=cost+profit

  data.frame(item.id, ensemble.id, cost, price, profit)
}
items = init_items()

## Create ensemble pricing data
init_ensembles = function(items) {
  items %>% group_by(ensemble.id) %>% summarize_each(funs(sum), cost, price, profit)
}
ensembles = init_ensembles(items)

## Attach dependencies
## https://github.com/timelyportfolio/functionplotR/issues/1#issuecomment-224369431
getdeps <- function() {
  htmltools::attachDependencies(
    htmltools::tagList(),
    c(
      htmlwidgets:::getDependency("datatables","DT")
    )
  )
}

# Define UI for application
ui <- shinyUI(
  navbarPage("Linked Table Test",
             tabPanel("Page 1", uiOutput("page1")),
             tabPanel("Page 2", uiOutput("page2"), getdeps())
  )
)

# Define server logic
server <- shinyServer(function(input, output, session) {
  output$page1 <- renderUI({
    inclRmd("./page1.Rmd")
  })

  output$page2 <- renderUI({
    inclRmd("./page2.Rmd")
  })
})


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

page1.Rmd

# Ensembles

Click on an ensemble to display detailed pricing information.
```{r}
tags$div(
  DT::renderDataTable(ensembles, rownames = FALSE)
)
```

page2.Rmd

# Items

```{r}
inputPanel(
  numericInput("ensemble.id", label = "Ensemble ID:", 0, min(ensembles$ensemble.id), max(ensembles$ensemble.id))
)

tags$div(
  renderText(paste0("Detailed pricing information for ensemble #",input$ensemble.id,":"))
)
tags$div(
  DT::renderDataTable(items %>% filter(ensemble.id==input$ensemble.id) %>% select(-ensemble.id), rownames = FALSE)
)
```

Answer 1

这应该给你工具来做你想做的事：

library(shiny)
library(DT)
ui <- fluidPage(
  tabsetPanel(
    tabPanel("One",
             DT::dataTableOutput("test1")
    ),
    tabPanel("two",
             numericInput("length","Length",0,0,10)
    )))
server <- function(input, output, session) {
  df <- reactive({
    cbind(seq_len(nrow(mtcars)),mtcars)
  })
  output$test1 <- DT::renderDataTable({
    df()
  },rownames=FALSE,options=list(dom="t"),
  callback=JS(
    'table.on("click.dt", "tr", function() {

    tabs = $(".tabbable .nav.nav-tabs li a");
    var data=table.row(this).data();

    document.getElementById("length").value=data[0];
    Shiny.onInputChange("length",data[0]);
    $(tabs[1]).click();
    table.row(this).deselect();})'
  ))

}
shinyApp(ui = ui, server = server)

当您单击数据表中的一行时，它会切换选项卡，并将数字输入的值更改为您选择的行中第一列的值。

编辑：您可能必须将数据表明确地放在闪亮的应用程序中，而不是从 r markdown 脚本中包含它们，因为我不相信 R Markdown 中的闪亮对象以可靠可读的方式具有 html Id。

编辑：我拿走了你的代码并让它工作：

library(shiny)
library(dplyr)
## Create item pricing data
set.seed(1234)
init_items = function() {
  item.id=1:1000
  ensemble.id=rep(1:100,each=10)
  cost=round(runif(1000,10,100), 2)
  profit=round(cost*runif(1000,0.01,0.15), 2)
  price=cost+profit

  data.frame(item.id, ensemble.id, cost, price, profit)
}
items = init_items()

## Create ensemble pricing data
init_ensembles = function(items) {
  items %>% group_by(ensemble.id) %>% summarize_each(funs(sum), cost, price, profit)
}
ensembles = init_ensembles(items)

## Attach dependencies
## https://github.com/timelyportfolio/functionplotR/issues/1#issuecomment-224369431
getdeps <- function() {
  htmltools::attachDependencies(
    htmltools::tagList(),
    c(
      htmlwidgets:::getDependency("datatables","DT")
    )
  )
}

# Define UI for application
ui <- shinyUI(fluidPage(
  tabsetPanel(#id="Linked Table Test",
    tabPanel("Page 1", DT::dataTableOutput("page1")),
    tabPanel("Page 2", inputPanel(
      numericInput("ensemble.id", label = "Ensemble ID:", 0, min(ensembles$ensemble.id), max(ensembles$ensemble.id))
    ),
    textOutput("page2"), DT::dataTableOutput("table2"),getdeps())
  )
))

# Define server logic
server <- shinyServer(function(input, output, session) {
  output$page1 <- DT::renderDataTable(ensembles, rownames = FALSE,
                                      callback=JS(
                                        'table.on("click.dt", "tr", function() {

    tabs = $(".tabbable .nav.nav-tabs li a");
    var data=table.row(this).data();
    document.getElementById("ensemble.id").value=data[0];
    Shiny.onInputChange("ensemble.id",data[0]);
    $(tabs[1]).click();
    table.row(this).deselect();
    })'                     
                                      ))


  output$table2 <- DT::renderDataTable(items %>% filter(ensemble.id==input$ensemble.id) %>% select(-ensemble.id), rownames = FALSE)

  output$page2 <- renderText({
    print(input$ensemble.id)
    paste0("Detailed pricing information for ensemble #",input$ensemble.id,":")
  })
})


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