CODEWITHSUNDEEP
rshinyshiny-reactivityrhandsontableshinymodules
SavedByJESUS
SavedByJESUS

Reputation: 3334

Using rhandsontable in a shiny module

The application

On startup, a 3 x 3 table is generated with values from 1 to 9 in a random order. What the app user can see is a blank 3 x 3 rhandsontable that he/she will use to try to guess where the generated values are. When the user clicks on the "Submit" button, the cells that contain the correct values turn green and all other cells remain as they are.

My issue

The cells where the user guessed right do not turn green when the user clicks the button. In other words, the conditional formatting does not work even though I got it to work before (that was in the first version of the app when I did not make use of shiny modules).

What I have done

The full project is in the following Github repository that potential users may want to clone instead of copying and pasting the code below: https://github.com/gueyenono/number_game

My project folder has 4 files. The first two files are the usual ui.R and server.R, which essentially call shiny modules (i.e. hot_module_ui() and hot_module()) . The modules are contained within the global.R file. The last file, update_hot.R, contains a function used in the modules.

ui.R

This file loads the required packages, provides a title for the app and calls hot_module_ui(). The module just displays a blank 3 x 3 rhandsontable and an actionButton().

library(shiny)
library(rhandsontable)
source("R/update_hot.R")

ui <- fluidPage(

  titlePanel("The number game"),

  mainPanel(
    hot_module_ui("table1")
  )
)

server.R

This file calls the hot_module(), which contains the code for the conditional formatting.

server <- function(input, output, session) {
  callModule(module = hot_module, id = "table1")
}

update_hot.R

This is the function which is called when the "Submit" button is called. The function has two arguments:

This is what the function does (full code for the file is at the end of this section):

  1. Get the user inputs
user_input <- hot_to_r(hot)
  1. Compare user inputs (user_input) to the true values (x) and store the row and column indices of the cells where the user guessed right
i <- which(user_input == x, arr.ind = TRUE)

  row_correct <- i[, 1] - 1
  col_correct <- i[, 2] - 1
  1. Update the current handsontable object with the row and column indices and use the renderer argument of the hot_cols() function to make background of corresponding cells green. Note that I use the hot_table() function to update the existing rhandsontable object. 
hot %>%
    hot_table(contextMenu = FALSE, row_correct = row_correct, col_correct = col_correct) %>%
    hot_cols(renderer = "function(instance, td, row, col, prop, value, cellProperties){
          Handsontable.renderers.TextRenderer.apply(this, arguments);

          if(instance.params){

            // Correct cell values
            row_correct = instance.params.row_correct
            row_correct = row_correct instanceof Array ? row_correct : [row_correct]
            col_correct = instance.params.col_correct
            col_correct = col_correct instanceof Array ? col_correct : [col_correct]


            for(i = 0; i < col_correct.length; i++){ 
              if (col_correct[i] == col && row_correct[i] == row) {
                  td.style.background = 'green';
              } 
            }

          return td;
        }")

Here is the full code for update_hot.R

update_hot <- function(hot, x){

  # Get user inputs (when the submit button is clicked)
  user_input <- hot_to_r(hot)

  # Get indices of correct user inputs
  i <- which(user_input == x, arr.ind = TRUE)

  row_correct <- i[, 1] - 1
  col_correct <- i[, 2] - 1

  # Update the hot object with row_index and col_index for user in the renderer
  hot %>%
    hot_table(contextMenu = FALSE, row_correct = row_correct, col_correct = col_correct) %>%
    hot_cols(renderer = "function(instance, td, row, col, prop, value, cellProperties){
          Handsontable.renderers.TextRenderer.apply(this, arguments);

          if(instance.params){

            // Correct cell values
            row_correct = instance.params.row_correct
            row_correct = row_correct instanceof Array ? row_correct : [row_correct]
            col_correct = instance.params.col_correct
            col_correct = col_correct instanceof Array ? col_correct : [col_correct]


            for(i = 0; i < col_correct.length; i++){ 
              if (col_correct[i] == col && row_correct[i] == row) {
                  td.style.background = 'green';
              } 
            }

          return td;
        }")
}

global.R

This is the file, which contains the shiny modules. The UI module (hot_module_ui()) has: - an rHandsontableOutput - an actionButton - I added a tableOutput in order to see where the generated values are (useful for testing the code)

The server module (hot_module()) calls the update_hot() function and attempts to update the handsontable in the app whenever the user clicks on the "Submit" button. I attempted to achieve this by using an observeEvent and a reactive value react$hot_display. On startup, react$hot_display contains a 3 x 3 data frame of NAs. When the button is clicked, it is updated with the new version of the handsontable (containing user inputs and conditional formatting). Here is the full code for global.R:

hot_module_ui <- function(id){

  ns <- NS(id)

  tagList(
    rHandsontableOutput(outputId = ns("grid")),
    br(),
    actionButton(inputId = ns("submit"), label = "Submit"),
    br(),
    tableOutput(outputId = ns("df"))
  )

}


hot_module <- function(input, output, session){

  values <- as.data.frame(matrix(sample(9), nrow = 3))

  react <- reactiveValues()

  observe({
    na_df <- values
    na_df[] <- as.integer(NA)
    react$hot_display <-  rhandsontable(na_df, rowHeaders = NULL, colHeaders = NULL)
  })

  observeEvent(input$submit, {
    react$hot_display <- update_hot(hot = input$grid, x = values)
  })

  output$grid <- renderRHandsontable({
    react$hot_display
  })

  output$df <- renderTable({
    values
  })
}

As mentioned at the beginning, the conditional formatting does not work when the "Submit" button is clicked and I am not sure why. Once again, you can access the full code on the following Github repository:

https://github.com/gueyenono/number_game

Upvotes: 1

Views: 2021

Answers (1)

SavedByJESUS
SavedByJESUS

Reputation: 3334

I finally found the solution to my issue. One of the biggest lessons I learned was that the hot_to_r() function does not work in custom functions. It must be used in the server function of a shiny app. This means that passing an rhandsontable object to a custom function and retrieving the data from within the function may not be a good idea (which was my story).

I am not sure it will be of interest to anyone, but here is my code, which works as intended:

ui.R

library(rhandsontable)
library(shiny)
source("R/update_hot.R")

shinyUI(fluidPage(

    # Application title
    titlePanel("The Number Game"),

    module_ui(id = "tab")
))

server.R

library(shiny)

shinyServer(function(input, output, session) {

    callModule(module = module_server, id = "tab")

})

global.R

module_ui <- function(id){

  ns <- NS(id)

  tagList(
    rHandsontableOutput(outputId = ns("hot")),
    actionButton(inputId = ns("submit"), label = "OK"),
    actionButton(inputId = ns("reset"), label = "Reset")
  )
}


module_server <- function(input, output, session){

  clicked <- reactiveValues(submit = FALSE, reset = FALSE)

  initial_hot <- rhandsontable(as.data.frame(matrix(NA_integer_, nrow = 3, ncol = 3)))
  correct_values <- as.data.frame(matrix(1:9, nrow = 3, byrow = TRUE))

  observeEvent(input$submit, {
    clicked$submit <- TRUE
    clicked$reset <- FALSE
  })

  updated_hot <- eventReactive(input$submit, {
    input_values <- hot_to_r(input$hot)
    update_hot(input_values = input_values, correct_values = correct_values)
  })


  observeEvent(input$reset, {
    clicked$reset <- TRUE
    clicked$submit <- FALSE
  })

  reset_hot <- eventReactive(input$reset, {
    initial_hot
  })


  output$hot <- renderRHandsontable({

    if(!clicked$submit & !clicked$reset){
      out <- initial_hot
    } else if(clicked$submit & !clicked$reset){
      out <- updated_hot()
    } else if(clicked$reset & !clicked$submit){
      out <- reset_hot()
    }

    out
  })
}

R/update_hot.R

update_hot <- function(input_values, correct_values){

  equal_ids <- which(input_values == correct_values, arr.ind = TRUE)
  unequal_ids <- which(input_values != correct_values, arr.ind = TRUE)

  rhandsontable(input_values) %>%
    hot_table(row_correct = as.vector(equal_ids[, 1]) - 1,
              col_correct = as.vector(equal_ids[, 2]) - 1,
              row_incorrect = as.vector(unequal_ids[, 1]) - 1,
              col_incorrect = as.vector(unequal_ids[, 2]) - 1) %>%

    hot_cols(renderer = "function(instance, td, row, col, prop, value, cellProperties){
          Handsontable.renderers.TextRenderer.apply(this, arguments);

          if(instance.params){

            // Correct cell values
            row_correct = instance.params.row_correct
            row_correct = row_correct instanceof Array ? row_correct : [row_correct]
            col_correct = instance.params.col_correct
            col_correct = col_correct instanceof Array ? col_correct : [col_correct]

            // Incorrect cell values
            row_incorrect = instance.params.row_incorrect
            row_incorrect = row_incorrect instanceof Array ? row_incorrect : [row_incorrect]
            col_incorrect = instance.params.col_incorrect
            col_incorrect = col_incorrect instanceof Array ? col_incorrect : [col_incorrect]


            for(i = 0; i < col_correct.length; i++){ 
              if (col_correct[i] == col && row_correct[i] == row) {
                  td.style.background = 'green';
              } 
            }

            for(i = 0; i < col_incorrect.length; i++){ 
              if (col_incorrect[i] == col && row_incorrect[i] == row) {
                  td.style.background = 'red';
              } 
            }
          }
          return td;
        }")
}

Upvotes: 2

Related Questions