如何根據該表中的觸發器將反應值插入到使用 rhandsontable 呈現的表中？

Question

在運行本文底部顯示的代碼時，使用 rhandsontable package 在 window 的右下角呈現了一個表（“hottable”），其中該表的第 2 行反映了來自input$choices object 的用戶輸入selectInput()在它的正上方呈現。 相反，我想改變這一點，從而使 dataframe“table1”中的“END”值在左側的基本 Shiny 表中呈現，反映在標記為“Floating reactive”的 rhandsontable“hottable”的第二行中，如如下圖所示，其中從 dataframe 到 select“END”的行由標記為“Term A”的 rhandsontable 第 1 行中的值觸發。 請問，關於如何做到這一點有什么建議嗎？

代碼：

library(rhandsontable)
library(shiny)
library(shinyjs)

mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Floating reactive','Term C','Term D') 

ui <- fluidPage(br(),
  column(6,
    sliderInput("periods","Nbr of months",min=1,max=20,value=10,step=1),
    sliderInput("beginAmt","Begin amount",min=100,max=500,value=250,step=50),
    sliderInput("npr","NPR",min=0.1,max=1,value=.3,step=0.1)
    ),
  column(6,
    sliderInput("mpr","MPR",min=0.1,max=1,value=.3,step=0.1),
    sliderInput("dft","DFT",min=0.1,max=1,value=.3,step=0.1),
    uiOutput("choices"),br(),
    ),
  br(),
  column(6,tableOutput("table1")),
  column(6,
         rHandsontableOutput('hottable'),
         fluidRow(column(1,br(),actionButton("addSeries", "Add",width = '70px')))
  )
)

server <- server <- function(input, output, session) {
  npr_vector <- reactive(rep(input$npr,input$periods))
  mpr_vector <- reactive(rep(input$mpr,input$periods))
  dft_vector <- reactive(rep(input$dft,input$periods))
  table2 <- reactiveVal(mydata)
  
  runOff <- reactive({
    f      <- function(x,y){x*(1+npr_vector()[y]-mpr_vector()[y]-dft_vector()[y]/12)}
    res    <- Reduce(f,seq(input$periods),init=input$beginAmt,accumulate=TRUE)
    b      <- head(res,-1)
    result <- data.frame(MO = seq(input$periods), 
                         NP = b*npr_vector(),  
                         MP = b*mpr_vector(), 
                         DFT = b*dft_vector()/12,   
                         END = res[-1]
                         )
  })
  
  output$table1 <- renderTable(runOff())
  
  observeEvent(input$hottable, {table2(hot_to_r(input$hottable))})
  
  output$hottable <- renderRHandsontable({rhandsontable(table2(),rowHeaderWidth=100,useTypes=TRUE)})
  
  observe({
    req(input$choices)
    tmpTable <- table2()
    tmpTable[2,] <- as.numeric(input$choices)
    table2(tmpTable)
  })
  
  output$choices <- 
    renderUI({
      selectInput(
        "choices", 
        label = "User selects value to reflect in row 2 of table below:",
        choices = c(1,2,3)
      )
    })
  
  observeEvent(input$addSeries, {
    newCol <- data.frame(c(1,1,0,1)) 
    newCol[2,] <- as.numeric(input$choices) 
    names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable)) + 1)
    table2(cbind(table2(), newCol))
  })
}

shinyApp(ui, server)

Answer 1

請檢查修改后的observe調用：

library(rhandsontable)
library(shiny)
library(shinyjs)

mydata <- data.frame('Series 1' = c(1,1,0,1), check.names = FALSE)
rownames(mydata) <- c('Term A','Floating reactive','Term C','Term D') 

ui <- fluidPage(br(),
                column(6,
                       sliderInput("periods","Nbr of months",min=1,max=20,value=10,step=1),
                       sliderInput("beginAmt","Begin amount",min=100,max=500,value=250,step=50)
                ),
                column(6,
                       sliderInput("mpr","MPR",min=0.1,max=1,value=.3,step=0.1),
                       sliderInput("dft","DFT",min=0.1,max=1,value=.3,step=0.1)
                ),
                column(12, sliderInput("npr","NPR",min=0.1,max=1,value=.3,step=0.1)),
                br(),
                column(6,tableOutput("table1")),
                column(6,
                       rHandsontableOutput('hottable'),
                       fluidRow(column(1,br(),actionButton("addSeries", "Add",width = '70px')))
                )
)

server <- server <- function(input, output, session) {
  npr_vector <- reactive(rep(input$npr,input$periods))
  mpr_vector <- reactive(rep(input$mpr,input$periods))
  dft_vector <- reactive(rep(input$dft,input$periods))
  table2 <- reactiveVal(mydata)
  
  runOff <- reactive({
    f      <- function(x,y){x*(1+npr_vector()[y]-mpr_vector()[y]-dft_vector()[y]/12)}
    res    <- Reduce(f,seq(input$periods),init=input$beginAmt,accumulate=TRUE)
    b      <- head(res,-1)
    result <- data.frame(MO = seq(input$periods), 
                         NP = b*npr_vector(),  
                         MP = b*mpr_vector(), 
                         DFT = b*dft_vector()/12,   
                         END = res[-1]
    )
  })
  
  output$table1 <- renderTable(runOff())
  
  observeEvent(input$hottable, {table2(hot_to_r(input$hottable))})
  
  output$hottable <- renderRHandsontable({rhandsontable(table2(),rowHeaderWidth=100,useTypes=TRUE)})
  
  observe({
    req(runOff(), table2())
    tmpTable <- table2()
    tmpTable[2,] <- runOff()$END[unlist(table2()[1,])]
    table2(tmpTable)
  })

  observeEvent(input$addSeries, {
    newCol <- data.frame(c(1,1,0,1)) 
    names(newCol) <- paste("Series", ncol(hot_to_r(input$hottable)) + 1)
    table2(cbind(table2(), newCol))
  })
}

shinyApp(ui, server)