从一个DataTable超链接到Shiny [英] Hyperlink from one DataTable to another in Shiny

问题描述

我有一个包含两个页面的Shiny应用程序：

I have a Shiny app that consists of two pages:

• 第1页显示带有摘要信息的DataTable（套装）。


• 第2页显示特定集合的详细定价信息（项目）是可以选择的。

• Page 1 displays a DataTable with summary information (ensembles).
• Page 2 displays detailed pricing info (items) for a specific ensemble, which is selectable.

当用户单击第1页上的一行时，我希望将它们带到第2页，并相应

When the user clicks on a row on page 1, I want them to be taken to page 2, with the corresponding ensemble selected.

以下代码创建了闪亮的应用和两个页面，但要求用户手动切换页面并手动输入合奏编号。

The below code creates the Shiny app and the two pages, but requires the user to switch pages and enter the ensemble number manually.

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

推荐答案

这应该为您提供执行所需功能的工具：

This should give you the tools to do what you want:

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)

在数据表中单击一行时，它会切换选项卡，并将数字输入的值更改为

When you click a row in the datatable, it switches tabs, and changes the value of the numeric input to the value of the first column in the row you selected.

编辑：您可能必须将数据表显式地放在闪亮的应用程序中，而不要从ar markdown脚本中包括它们，因为我不认为R Markdown中的闪亮对象具有可靠可读的html ID。

edit: you will probably have to put your datatables explicitly in the shiny app and not include them from a r markdown script, since I don't believe shiny objects in R Markdown have html Ids in a reliably readable way.

编辑：我拿了你的代码并使它起作用：

edit: I took your code and got it to work:

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)

这篇关于从一个DataTable超链接到Shiny的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！