track closest values in a table Shiny r

Question

I am building a Shiny App that does random simulations of some stuff in three ways and saves the results in a table. I want the table to (1) fill the cell green for the closest value to the correct answer, and (2) include a line on bottom tracking total number of times each test group has been the closest.

what I have:

what I want:

Here's the code I'm using: By the way, in this example there are ties, but that won't really be possible in the real thing, so probably not necessary to deal with.

#
# This is a Shiny web application. You can run the application by clicking
# the 'Run App' button above.
#
# Find out more about building applications with Shiny here:
#
#    http://shiny.rstudio.com/
#

library(shiny)

# Define UI for application that draws a histogram
ui <- fluidPage(

    # Application title
    titlePanel("test"),

    # Sidebar with a slider input for number of bins 
    sidebarLayout(
        sidebarPanel(
            actionButton("random_select",
                         "Generate Random Numbers",
                         width = 'auto')
        ),

        # Show a plot of the generated distribution
        mainPanel(
           tableOutput("results_table_output")
        )
    )
)

# Define server logic required to draw a histogram
server <- function(input, output) {

    counter <- reactiveValues(countervalue = 0)
    
    observeEvent(input$random_select,{
        counter$countervalue = counter$countervalue + 1
    }
    )

    
    results <- reactiveValues(
        table = list(trial = NA,
                     answer =NA,
                     test_1 = NA,
                     test_2 = NA,
                     test_3 = NA)
    )
    
    observeEvent(counter$countervalue,{
        results$table$trial[counter$countervalue] <- as.integer(counter$countervalue)
        results$table$answer[counter$countervalue] <- sample(1:10,1)
        results$table$test_1[counter$countervalue] <- sample(1:10,1)
        results$table$test_2[counter$countervalue] <- sample(1:10,1)
        results$table$test_3[counter$countervalue] <- sample(1:10,1)
                
    })
    
    output$results_table_output <- renderTable({
        results$table
    })
    
    
    }

# Run the application 
shinyApp(ui = ui, server = server)

Answer 1

Disclaimer

I would also fall back to a more advanced table rendering engine like DT. However, in the following I show another solution which works with renderTable from "base" shiny.

---

renderTable + JS Solution

If you don't mind using some JavaScript you can use the following snippet:

library(shiny)
library(shinyjs)
js <- HTML("function mark_cells() {
   $('.mark-cell').parent('td').css('background-color', 'steelblue');
}

function add_totals() {
   const ncols = $('table th').length;
   const $col_totals = Array(ncols).fill().map(function(el, idx) {
      const $cell = $('<td></td>');
      if (idx == 1) {
         $cell.text('total:');
      } else if (idx > 1) {
         $cell.text($('table tr td:nth-child(' + (idx + 1) + ') .mark-cell').length);
      }
      return $cell;
   })
   $('table tfoot').remove();
   $('table > tbody:last-child')
      .after($('<tfoot></tfoot>').append($('<tr></tr>').append($col_totals))); 
}

function mark_table() {
   mark_cells();
   add_totals()
}
")

make_run <- function(i, answer, tests = integer(3))  {
  cn <- c("trial", "answer", paste0("test_", seq_along(tests)))
  if (is.null(i)) {
    line <- matrix(integer(0), ncol = length(cn))
    colnames(line) <- cn
  } else {
    line <- matrix(as.integer(c(i, answer, tests)), ncol = length(cn))
    colnames(line) <- cn
  }
  as.data.frame(line)
}

mark_best <- function(row) {
  truth <- row[2]
  answers <- row[-(1:2)]
  dist <- abs(answers - truth)
  best <- dist == min(dist)
  answers[best] <- paste0("<span class = \"mark-cell\">", answers[best], "</span>")
  c(row[1:2], answers)
}

ui <- fluidPage(
  useShinyjs(),
  tags$head(tags$script(js)),
  sidebarLayout(
    sidebarPanel(
      actionButton("random_select",
                   "Generate Random Numbers")
    ),
    mainPanel(
      tableOutput("results_table_output")
    )
  )
)

server <- function(input, output, session) {
  results <- reactiveVal(make_run(NULL))
  observeEvent(input$random_select, {
    res <- results()
    results(rbind(res, make_run(nrow(res) + 1, sample(10, 1), sample(10, 3, TRUE))))
  })
  
  output$results_table_output <- renderTable({
    res <- results()
    if (nrow(res) > 0) {
      res <- as.data.frame(t(apply(res, 1, mark_best)))
      session$onFlushed(function() runjs("mark_table()"))
    }
    res
  }, sanitize.text.function = identity)
}

shinyApp(ui = ui, server = server)

Explanation

• In the renderTable function, we call mark_best where we surround the "winning" cells with <span class = "mark-cell">. This helps us on the JS side to identify which cells are the winners.
• In order to not escape the HTML in it, we use the argument sanitize.text.function which is responsible for, well, sanitizing strings in the cell. Because we want to print them as is, we supply the identity function.
• We include 3 JavaScript functions in the <head> of the document, which
  • color the parent <td> of our marked cells (mark_cells())
  • add column totals to the table. This is done by counting the .mark-cell marked cells in each column (add_totals)
  • a convenience wrapper to call both functions (mark_table())
• In order to be able to actually call the JS function we rely on shinyjs. This is however, merely syntactic sugar and could be achieved otherwise as well (if you mind the additional library). To make shinyjs work, we need to include a call to useShinyjs in the UI.
• All what is left to do is to call mark_table in the renderTable function. To make sure that the table is rendered properly, we do not call the JS function right away but use session$onFlushed to register the call to be run after the next flush happens.