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

Question

I'm in the process of rendering a transition plot. In order to get there with the below reproducible code, I'm subsetting data frame results() (shown as the first rendered table in Shiny when running the code) and creating new data frame extractResults() (shown as the 2nd table when running the code). I'm trying to set the row names of extractResults() the same as it's column names but can't quite get it to work.

Easy to do in base R with rownames(x) <- colnames(x), where x is the data frame, but I can't get this to work in Shiny. Must be some other trick to use when dealing with reactivity. The image at the bottom better explains.

The commented-out line in the code shows one of my attempts to do this.

Reproducible code:

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)

Replace your commented line with `extractResults %>% add_column(Row=colnames(extractResults), .before=1)` . And add `library(tibble)` at the head of your code. — Limey, Apr 26 '22 at 14:51
Or, replace your commented line with `row.names(extractResults) <- colnames(extractResults); extractResults` (on two lines: remember, reactives need to return something!) and change your `output$resultsPlot` to `output$resultsPlot <- renderTable({extractResults()}, rownames=TRUE)`. [And, I'd change the `outputId` too: it's not a good idea to use `xxxxPlot` as the id of something you create with `renderTable`...] — Limey, Apr 26 '22 at 15:02
Hi Limey, thanks for setting me straight. I opted for the 2nd recommendation, because otherwise I'd have to de-tibble the resulting data. My main lessons are (a) don't forget extractResults in a separate line since reactives need to return something, and (b) don't forget rownames = TRUE in renderTable. Through repetition I'll remember this. — Curious Jorge - user9788072, Apr 26 '22 at 17:44

Curious Jorge - user9788072 · Accepted Answer · 2022-04-27T03:43:05.973

This question/solution was used to complete the answer to this related post: An up-to-date method for plotting a transition probability matrix?

Below is the OP code revised to reflect Limey's solution posited in his 2nd comment above:

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)

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

1 Answers1