Блестящее наблюдение за событием в динамически создаваемой вторичной таблице

Question

Я использовал наблюдающее событие, чтобы отследить, когда пользователь щелкает строку таблицы, и получить идентификатор строки, чтобы отобразить новую вкладку с детализацией данных для выбранной категории. Я хочу иметь возможность сделать то же самое во вновь созданной таблице, чтобы отобразить детали данных, соответствующие конкретному выбранному случаю, но я не могу найти, как ссылаться на таблицы, созданные на лету.

library(shiny)
library(dplyr)
library(DT)

ui <- fluidPage(
    titlePanel("Old Faithful Geyser Data"),
    sidebarLayout(
        sidebarPanel(
            dateRangeInput(inputId="daterange",label = "Date Range",start = "2019-09-01")
        ),

        mainPanel(
            tabsetPanel( id = "tabs",
                         tabPanel("Table",
                                  dataTableOutput("summary"))
            )
        )
    )
)


tabledata <- as_data_frame(
    bind_cols(
        value = c(3,6,9,2,6,8,3),
        category=c("blue","red","green","blue","green","green","red")
    )
)


server <- function(input, output) {

    categories_summary <- reactive({ 
        tabledata %>% 
            group_by(category) %>% 
            summarise(mean=mean(value),median=median(value)) %>% 
            ungroup()
    })

    output$summary <- DT::renderDataTable({
        categories_summary()
    })

    tab_list <- NULL

    observeEvent(input$summary_rows_selected,{  
        shiny::validate(
            need(length(input$summary_rows_selected) > 0, "Select rows to drill down!")
        )

        step <- input$summary_rows_selected[length(input$summary_rows_selected)]

        tab_title <- paste(categories_summary()[step, ]$category)

        if(tab_title %in% tab_list == FALSE){
            t1 <- tabledata[tabledata$category ==categories_summary()[step, ]$category, ]

            appendTab(inputId = "tabs",
                      tabPanel(
                          tab_title,
                          DT::renderDataTable(t1)
                      ))

            tab_list <<- c(tab_list, tab_title) 
        }
    })
}

shinyApp(ui = ui, server = server)

Спасибо

Я нашел возможное решение, добавив jQuery наблюдателя через:

<script type="text/javascript">
$('body').on('click','div[data-value="blue"] table tbody',
        function (e) {
    e = e || window.event;
    var data = [];
    var target = e.srcElement || e.target;
    while (target && target.nodeName !== "TR") {
        target = target.parentNode;
    }
    if (target) {
        var cells = target.getElementsByTagName("td");
        for (var i = 0; i < cells.length; i++) {
            data.push(cells[i].innerHTML);
        }
    }

    console.log(data[0],data[1],data[2]);
}
);
</script>

Кажется, он работает нормально. Я думаю, что могу обойти это.

Answer 1

Следуя этому пути, я пришел к возможному решению.

library(shiny)
library(dplyr)
library(DT)

ui <- fluidPage(
    titlePanel("Old Faithful Geyser Data"),
    sidebarLayout(
        sidebarPanel(
            dateRangeInput(inputId="daterange",label = "Date Range",start = "2019-09-01"),
            tags$input(type = "hidden",id = "table_pm_selected", value = "x")  
        ),

        mainPanel(
            includeHTML("catch_new_tables.js"),
            tabsetPanel( id = "tabs",
                         tabPanel("Table",
                                  dataTableOutput("summary")),
                        tabPanel("Text",textOutput("textito"))
            )
        )
    )
)


tabledata <- as_data_frame(
    bind_cols(
        value = c(3,6,9,2,6,8,3),
        category=c("blue","red","green","blue","green","green","red")
    )
)


server <- function(input, output) {

    categories_summary <- reactive({ 
        tabledata %>% 
            group_by(category) %>% 
            summarise(mean=mean(value),median=median(value)) %>% 
            ungroup()
    })

    output$summary <- DT::renderDataTable({
        categories_summary()
    })

    output$textito <- renderText({
        paste0("'",input$table_pm_selected["value"],"'")
    })


    tab_list <- NULL

    observeEvent(input$summary_rows_selected,{  
        shiny::validate(
            need(length(input$summary_rows_selected) > 0, "Select rows to drill down!")
        )

        step <- input$summary_rows_selected[length(input$summary_rows_selected)]

        tab_title <- paste(categories_summary()[step, ]$category)

        if(tab_title %in% tab_list == FALSE){
            t1 <- tabledata[tabledata$category ==categories_summary()[step, ]$category, ]

            appendTab(inputId = "tabs",
                      tabPanel(
                          tab_title,
                          DT::renderDataTable(t1)
                      ))

            tab_list <<- c(tab_list, tab_title)
        }
    })

    observeEvent(input$table_pm_selected, {
                 print(input$table_pm_selected)
                    output$textito <- renderText(input$table_pm_selected)
                 })
}

shinyApp(ui = ui, server = server)

С файлом javascript:

<script type="text/javascript">
    // get one item by id with $ and attach an event listener:
$('body').on('click',('div[data-value="blue"] table tbody , div[data-value="green"] table tbody , div[data-value="red"] table tbody'),
    // get the dropdown and assign to element
        //x = document.querySelectorAll('div[data-value="blue"] table tbody')[0];
        function (e) {
    e = e || window.event;
    var data = [];
    var target = e.srcElement || e.target;
    while (target && target.nodeName !== "TR") {
        target = target.parentNode;
    }
    if (target) {
        var cells = target.getElementsByTagName("td");
        for (var i = 0; i < cells.length; i++) {
            data.push(cells[i].innerHTML);
        }
    }


    Shiny.setInputValue("table_pm_selected",data[2])
}
);
</script>

Я почти уверен, что возможно Будь более элегантным решением, но оно работает так, мне хорошо.

Answer 2

Очень интересная концепция, мне интересно, если после того, как вы отправите ее в пользовательский интерфейс, у вас будет новая вкладка, на которую можно будет ссылаться внутри сервера? Не уверен, будет ли это новый JS или нет. Может быть, вы можете иметь флажки цвета, а затем просто обновить таблицу и иметь несколько вкладок для разных вариантов выбора