如何更改在 Shiny 中呈现的反应式数据框的行名称？

Question

我正在渲染过渡图。为了使用下面的可重现代码到达那里，我正在对数据框 results() 进行子集化（显示为运行代码时 Shiny 中第一个渲染的 table ）并创建新的数据框 extractResults()（在运行代码中显示为第2个table）。我正在尝试将 extractResults() 的行名称设置为与其列名称相同，但无法完全正常工作。

使用 rownames(x) <- colnames(x) 在 base R 中很容易做到，其中 x 是数据框，但我无法让它在 Shiny 中工作。在处理反应性时必须使用其他一些技巧。底部的图片更好地解释了。

代码中被注释掉的行显示了我的尝试之一。

可重现代码：

library(DT)
library(shiny)
library(dplyr)
library(data.table)

data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
    State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X9")
  )

numTransit <- function(x, from=1, to=3){
  setDT(x)
  unique_state <- unique(x$State)
  all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
  dcast(x[, .(from_state = State[from], 
              to_state = State[to]), 
          by = ID]
        [,.N, c("from_state", "to_state")]
        [all_states,on = c("from_state", "to_state")], 
        to_state ~ from_state, value.var = "N"
  )
}

ui <- fluidPage(
  tags$head(tags$style(".datatables .display {margin-left: 0;}")), 
  h4(strong("Transition table inputs:")),
  numericInput("transFrom", "From period:", 1, min = 1, max = 3),
  numericInput("transTo", "To period:", 2, min = 1, max = 3),
  h4(strong("Output transition table:")), 
  DTOutput("resultsDT"),
  h4(strong("Extract of above transition table:")), 
  tableOutput("resultsPlot")
)

server <- function(input, output, session) {
  
  results <- 
    reactive({
      results <- numTransit(data, input$transFrom, input$transTo) %>% 
        replace(is.na(.), 0) %>%
        bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
      results <- cbind(results, Sum = rowSums(results[,-1]))
      results %>% 
        mutate(across(-1, ~ .x / .x[length(.x)])) %>% 
        replace(is.na(.), 0) %>% 
        mutate(across(-1, scales::percent_format(accuracy = 0.1)))
    })
  
  extractResults <- 
    reactive({
      extractResults <- 
        data.frame(lapply(results()[1:nrow(results())-1,2:nrow(results())], 
                          function(x) as.numeric(sub("%", "", x))/100))
      # extractResults <- row.names(extractResults) <- colnames(extractResults)
    })
  
  output$data <- renderTable(data)
  
  output$resultsDT <- renderDT(server=FALSE, {datatable(data = results())})
  
  output$resultsPlot <- renderTable({extractResults()})
}

shinyApp(ui, server)

Answer 1

此question/solution用于完成此相关post的答案：

以下是修改后的 OP 代码，以反映 Limey 在上面第二条评论中提出的解决方案：

library(DT)
library(shiny)
library(dplyr)
library(data.table)

data <- 
  data.frame(
    ID = c(1,1,1,2,2,2,3,3,3),
    Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
    Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
    State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X9")
  )

numTransit <- function(x, from=1, to=3){
  setDT(x)
  unique_state <- unique(x$State)
  all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
  dcast(x[, .(from_state = State[from], 
              to_state = State[to]), 
          by = ID]
        [,.N, c("from_state", "to_state")]
        [all_states,on = c("from_state", "to_state")], 
        to_state ~ from_state, value.var = "N"
  )
}

ui <- fluidPage(
  tags$head(tags$style(".datatables .display {margin-left: 0;}")), 
  h4(strong("Transition table inputs:")),
  numericInput("transFrom", "From period:", 1, min = 1, max = 3),
  numericInput("transTo", "To period:", 2, min = 1, max = 3),
  h4(strong("Output transition table:")), 
  DTOutput("resultsDT"),
  h4(strong("Extract of above transition table:")), 
  tableOutput("resultsPlot")
)

server <- function(input, output, session) {
  
  results <- 
    reactive({
      results <- numTransit(data, input$transFrom, input$transTo) %>% 
        replace(is.na(.), 0) %>%
        bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
      results <- cbind(results, Sum = rowSums(results[,-1]))
      results %>% 
        mutate(across(-1, ~ .x / .x[length(.x)])) %>% 
        replace(is.na(.), 0) %>% 
        mutate(across(-1, scales::percent_format(accuracy = 0.1)))
    })
  
  extractResults <- 
    reactive({
      extractResults <- 
        data.frame(lapply(results()[1:nrow(results())-1,2:nrow(results())], 
                          function(x) as.numeric(sub("%", "", x))/100))
      row.names(extractResults) <- colnames(extractResults) # << Limey fix
      extractResults # << Limey fix
    })
  
  output$data <- renderTable(data)
  
  output$resultsDT <- renderDT(server=FALSE, {datatable(data = results())})
  
  output$resultsPlot <- renderTable({extractResults()}, 
                                    rownames=TRUE # << Limey fix
                                    )

}

shinyApp(ui, server)

如何更改在 Shiny 中呈现的反应式数据框的行名称？

How to change row names of reactive data frame rendered in Shiny?

r

dataframe

shiny

shiny-reactivity