Hyperlink from one DataTable to another in Shiny

问题

I have a Shiny app that consists of two pages:

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

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

回答1:

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.

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)

来源：https://stackoverflow.com/questions/38797646/hyperlink-from-one-datatable-to-another-in-shiny

标签

Shiny