在闪亮的模块中使用rhandsontable

Question

应用程序

在启动时，以随机顺序生成3 x 3表，其值为1到9。 应用程序用户可以看到的是一个空白的3 x 3 rhandsontable ，他/她将用它来猜测生成值的位置。 当用户单击“提交”按钮时，包含正确值的单元格将变为绿色，而所有其他单元格保持原样。

我的问题

当用户点击按钮时，用户猜对的单元格不会变为绿色。 换句话说，条件格式化不起作用，即使我之前工作（当我没有使用闪亮的模块时，在应用程序的第一个版本）。

我做了什么

完整项目位于以下Github存储库中，潜在用户可能希望克隆而不是复制和粘贴以下代码： https ： //github.com/gueyenono/number_game

我的项目文件夹有4个文件。 前两个文件是通常的ui.R和server.R ，它们基本上调用闪亮的模块（即hot_module_ui()和hot_module() ）。 这些模块包含在global.R文件中。 最后一个文件update_hot.R包含模块中使用的函数。

ui.R

此文件加载所需的包，为应用程序提供标题并调用hot_module_ui() 。 该模块只显示一个空白的3 x 3 rhandsontable和一个actionButton() 。

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

ui <- fluidPage(

  titlePanel("The number game"),

  mainPanel(
    hot_module_ui("table1")
  )
)

server.R

此文件调用hot_module() ，其中包含条件格式的代码。

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

update_hot.R

这是在调用“提交”按钮时调用的函数。 该函数有两个参数：

• hot ：应用程序中的动手
• x ：启动时生成的值

这就是函数的作用（文件的完整代码在本节末尾）：

1. 获取用户输入

user_input <- hot_to_r(hot)

2. 将用户输入（ user_input ）与真值（ x ）进行比较，并存储用户猜对的单元格的行索引和列索引

i <- which(user_input == x, arr.ind = TRUE)

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

3. 使用行和列索引更新当前的handsontable对象，并使用hot_cols()函数的renderer参数使相应单元格的背景为绿色。 请注意，我使用hot_table()函数来更新现有的rhandsontable对象。

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;
        }")

这是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

这是文件，其中包含闪亮的模块。 UI模块（ hot_module_ui() ）具有： - 一个rHandsontableOutput - 一个actionButton - 我添加了一个tableOutput ，以便查看生成的值在哪里（对于测试代码很有用）

服务器模块（ hot_module() ）调用update_hot()函数，并在用户单击“提交”按钮时尝试更新应用程序中的联系人。 我试图通过使用observeEvent实现这一点，并且反应值react$hot_display 。 在启动时， react$hot_display包含一个3 x 3的NA s数据帧。 单击该按钮时，将使用新版本的handsontable（包含用户输入和条件格式）进行更新。 以下是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
  })
}

如开头所述，当单击“提交”按钮时，条件格式不起作用，我不知道为什么。 您可以再次访问以下Github存储库中的完整代码：

https://github.com/gueyenono/number_game

Answer 1

我终于找到了我的问题的解决方案。 我学到的最重要的一课是hot_to_r()函数在自定义函数中不起作用。 它必须用于闪亮应用程序的服务器功能。 这意味着将rhandsontable对象传递给自定义函数并从函数中检索数据可能不是一个好主意（这是我的故事）。

我不确定任何人都会感兴趣，但这是我的代码，它按预期工作：

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;
        }")
}