Блог

Пользователь сначала выбирает значение. На основе этого отображается таблица rhandsontable с несколькими пустыми столбцами с раскрывающимися параметрами — за исключением последнего столбца, Type_action. Этот столбец, который доступен только для чтения, должен автоматически обновляться на основе значений в столбцах Y и Z следующим образом: если значение в столбце Y меньше значения в столбце Z, Type_action должен принимать значение «Обновить», в противном случае значение «Понизить».

Ниже приведена моя попытка, которая не приводит к получению какого-либо значения для столбца Type_action:

 library(shiny)
library(rhandsontable)
library(dplyr)
library(shinydashboard)

ui <-  fluidPage( fluidRow(column(6, uiOutput("selA"))),
                  fluidRow(column(6, rHandsontableOutput('tbl1'))
           ) 
      ) 


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

  dt0 <- data.frame( A = c("S2","S2","S2","S4","S4","S4"),
                     B = c("1","2","3","1","2","3"),
                     C = c(10,20,30,40,15,25),
                     D  = c("A","B","C","D","E","F"))

# get the data for the selected BA
dt <- reactive(subset(dt0, A %in% input$selA))

# Render selectInput selBA
output$selA <- renderUI({
   ba <- as.vector( unique(dt0$A) )
   selectInput("selA","Choose BA", choices = ba)    
})

DF <- data.frame("X" = c(""),
               "Y" = c(""),
               "Z" = c(""),
               "Type_action" = c(""))

 values <- reactiveValues(data = DF)
 Y      <- reactiveVal()
 Z      <- reactiveVal()

observe({
 if(!is.null(input$tbl1)){
   values$data <- as.data.frame(hot_to_r(req(input$tbl1)))
    }
})

observeEvent(input$tbl1,{
       Y(hot_to_r(input$tbl1)$Y)},
       ignoreInit= TRUE
)

observeEvent(input$tbl1,{
   Z(hot_to_r(input$tbl1)$Z)}, 
   ignoreInit= TRUE
)

output$tbl1 = renderRHandsontable({
  req(input$selA)

  tmpTable <- rhandsontable(values$data, rowHeaders = FALSE, selectCallback = TRUE, width = 
                            1000, height = 500) %>% 
              hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>% 
              hot_col(col = "X", type = "dropdown", colWidths = 90, source = 
                       sort(unique(dt()$B))) %>% 
              hot_col(col = "Y", type = "dropdown", colWidths = 65, source = 
                      sort(unique(dt()$D))) %>% 
              hot_col(col = "Z", type = "dropdown", colWidths = 60,source = 
                      sort(unique(dt()$D))) %>% 
              hot_col(col = "Type_action", colWidths = 50, readOnly = TRUE, type = "text")  


 if(!is.null(input$tbl1_select$select$r) amp;amp; !is.na(values$data$Y[input$tbl1_select$select$r]) 
  amp;amp; !is.na(values$data$Z[input$tbl1_select$select$r])){
   tmpTable <- hot_col(tmpTable,col = "Type_action", type = "text", colWidths = 60, 
                      source = ifelse(as.numeric(factor(Y())) < as.numeric(factor(Z())),"u","d"))  
                       
  }
 tmpTable
 })
}

shinyApp(ui, server)
  

source Аргумент hot_col принимает

вектор вариантов для типов столбцов select, dropdown и автозаполнения

не реализовано изменение содержимого текстовой ячейки (как вы пытались в приведенном выше коде).

Мы можем изменить текстовый столбец, изменив базовый (реактивный) data.frame.

Пожалуйста, проверьте следующее:

 library(shiny)
library(rhandsontable)
library(dplyr)
library(shinydashboard)

ui <-  fluidPage( fluidRow(column(6, uiOutput("selA"))),
                  fluidRow(column(6, rHandsontableOutput('tbl1'))
                  ) 
) 


server <- function(input, output, session){
  
  dt0 <- data.frame( A = c("S2","S2","S2","S4","S4","S4"),
                     B = c("1","2","3","1","2","3"),
                     C = c(10,20,30,40,15,25),
                     D  = c("A","B","C","D","E","F"))
  
  # get the data for the selected BA
  dt <- reactive(subset(dt0, A %in% input$selA))
  
  # Render selectInput selBA
  output$selA <- renderUI({
    ba <- as.vector( unique(dt0$A) )
    selectInput("selA","Choose BA", choices = ba)    
  })
  
  DF <- data.frame("X" = c(""),
                   "Y" = c(""),
                   "Z" = c(""),
                   "Type_action" = c(""))
  
  values <- reactiveValues(data = DF)
  Y      <- reactiveVal()
  Z      <- reactiveVal()
  
  observe({
    if(!is.null(input$tbl1)){
      values$data <- as.data.frame(hot_to_r(req(input$tbl1)))
    }
  })
  
  observeEvent(input$tbl1,{
    Y(hot_to_r(input$tbl1)$Y)},
    ignoreInit= TRUE
  )
  
  observeEvent(input$tbl1,{
    Z(hot_to_r(input$tbl1)$Z)}, 
    ignoreInit= TRUE
  )
  
  output$tbl1 = renderRHandsontable({
    req(input$selA)
    
    tmpTable <- rhandsontable(values$data, rowHeaders = FALSE, selectCallback = TRUE, width = 
                                1000, height = 500) %>% 
      hot_table(highlightCol = TRUE, highlightRow = TRUE, stretchH = "all") %>% 
      hot_col(col = "X", type = "dropdown", colWidths = 90, source = 
                sort(unique(dt()$B))) %>% 
      hot_col(col = "Y", type = "dropdown", colWidths = 65, source = 
                sort(unique(dt()$D))) %>% 
      hot_col(col = "Z", type = "dropdown", colWidths = 60,source = 
                sort(unique(dt()$D))) %>% 
      hot_col(col = "Type_action", colWidths = 50, readOnly = TRUE, type = "text")  
    
    
    if(!is.null(input$tbl1_select$select$r) amp;amp; !is.na(values$data$Y[input$tbl1_select$select$r]) 
       amp;amp; !is.na(values$data$Z[input$tbl1_select$select$r])){
      values$data$Type_action <- ifelse(match(Y(), LETTERS) < match(Z(), LETTERS),"Upgrade","Downgrade")
      
    }
    tmpTable
  })
}

shinyApp(ui, server)