光沢のあるアプリケーションデータは、デフォルトでは特別な入力ウィジェットでは表示されません

Question

データベースにあるデータを編集できる光沢のあるアプリケーションがあります。私のアプリケーションでは、IDを選択して対応するデータを取得します。 （この例の「レコード」の例）このデータは、さまざまな光沢のあるウィジェットに書き込まれ、それらを編集することができます。 （「textID」と「remarksID」の下の例では）編集して送信ボタンを押すと、データベースのデータが更新されます。

これはあまり複雑ではありませんし、通常の光沢のあるウィジェットを使用している場合はそうではありません。しかし、私は特別な手作りの入力ウィジェットを使用しています（次のようにSO答え：How to create TextArea as input in a Shiny webapp in R?）。 javascriptを使用することにより、手作業の入力ウィジェットを記入することができます。しかし、ある意味では入力値として認識されず、画面でしか視覚化されません。手作りの入力ウィジェットを編集するとき、それは入力値として認識されます。

これはまだ大きな問題ではないようです。しかし、手作業による入力値を変更したくないとし、他の入力値を変更して編集を提出するとします。ハンドメイドの入力値が空の文字列に変更されます。

下記の光沢のあるアプリケーションで問題が示されます。備考入力ウィジェットの視覚化された入力は、デフォルトでは表示されません。 （データベースに返信されます）

library(shiny) 
library(shinyjs) 

jsCode<-"shinyjs.FillRemarks = function(remarks){document.getElementById('remarksID').value = remarks}" 

record <- structure(list(ID = "x1y2z3", 
         Country = "Netherlands", 
         Remarks = "Bla bla bla bla bla bla bla bla bla bla bla bla bla bla bla blabla bla bla bla bla"), 
         .Names = c("ID","Country", "Remarks"), 
         class = "data.frame", row.names = 1L) 


ui <- shinyUI(fluidPage(mainPanel(
    useShinyjs(), 
    extendShinyjs(text = jsCode), 
    fluidRow( 
    br(), 
    column(2, 
    selectInput("selectID",label = "Select ID:", choices = record$ID, selected = record$ID) 
    ), 
    br(),br(),br(),hr() 
), 
    fluidRow(
    column(12, 
    textInput("textID",label = "Country:") 
    ) 
), 
    fluidRow( 
    column(3, 
      tags$p(id="remarksLabelID","Remarks:"), 
      tags$textarea(id="remarksID", rows=3, cols=40, "") 
    ), 
    tags$style(type='text/css', "#remarksLabelID { 
       display: inline-block; 
       max-width: 100%; 
       margin-bottom: 5px; 
       font-weight: 700; 
       }"), 
    tags$style(type='text/css', "#remarksID { 
       resize: none; 
       width: 100%; 
       display: block; 
       padding: 6px 12px; 
       font-size: 14px; 
       line-height: 1.42857143; 
       color: #555; 
       background-color: #fff; 
       background-image: none; 
       border: 1px solid #ccc; 
       border-radius: 4px; 
       }") 


    ), 
    fluidRow( 

    hr(), 
    column(12, 

    titlePanel("Preview"), 

    tableOutput("tableID") 
    ) 
) 

))) 

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

    observeEvent(input$selectID,{ 
    updateTextInput(session, "textID", label = "Country:", value = record$Country) 
    print(js$FillRemarks(record$Remarks)) 

    }) 


    observe({ 

    outputTable <- structure(list(ID = record$ID, 
            Country = input$textID, 
            Remarks = input$remarksID), 
           row.names = 1L, class = "data.frame") 

    output$tableID <- renderTable({ 
    outputTable 
    }) 
    }) 
} 

shinyApp(ui=ui, server=server) 

私は間違った方向に考えていますか？ また、この質問の良いタイトルを考え出すことができません。

Answer 1

私はあなたが正しいと理解しているかどうかは完全にはわかりませんが、私は答えようとします。あなたはのsubmitButtonは、光沢のあるアプリケーションに存在する場合、それはボタンが押されるまでサーバーに更新を送信しないように、ページ上のすべての入力が発生することを考慮しなければならない送信ボタンについて

1. 。つまり、それを押すとすべての入力がサーバーに返されます。あなたのケースでは、submitButtonを使用しないでactionButtonを使用するのが最善です。なぜなら、どの入力がコードの再実行をトリガーするかを細かく制御できるからです。

2. あなたのスニペットを変更しました。アクションボタンも含め、remarksID変数の値を更新するもう1行のjavascriptを追加していますので、初めて実行すると空ではありません。私はそれが今あなたが望むように動作すると思います。

あなたがuiに追加する必要があるJS行は、jsCode2<-"shinyjs.updateRemarks = function(val){ Shiny.onInputChange('remarksID', val); }"です。サーバー上のremarksIDを更新します。これはプログラム的に変更された入力であるため、このようにする必要があります。これに対して光沢のある反応モデルをありがとう。その後

：あなたはここでそれを使用する必要がserver.Rで

extendShinyjs(text = jsCode), 
extendShinyjs(text = jsCode2), 

：

updateTextInput(session, "textID", label = "Country:", value = record$Country) 
    js$updateRemarks(record$Remarks) 
    js$FillRemarks(record$Remarks) 

最後に、あなたがアクションボタンを使用するためにserver.Rにもこれを追加する必要があります。

observeEvent(input$button, { 
    print(input$selectID) 
    print(input$textID) 
    print(input$remarksID) 
    }) 

完全なスニペットは、次のとおりです。

サーバー。R

library(shiny) 
library(shinyjs) 

record <- structure(list(ID = "x1y2z3", 
         Country = "Netherlands", 
         Remarks = "Bla bla bla bla bla bla bla bla bla bla bla"), 
        .Names = c("ID","Country", "Remarks"), 
        class = "data.frame", row.names = 1L) 

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

    observeEvent(input$selectID,{ 
    updateTextInput(session, "textID", label = "Country:", value = record$Country) 
    js$updateRemarks(record$Remarks) 
    js$FillRemarks(record$Remarks) 
    }) 


    observeEvent(input$button, { 
    print(input$selectID) 
    print(input$textID) 
    print(input$remarksID) 
    }) 

    observe({ 
    outputTable <- structure(list(ID = record$ID, 
            Country = input$textID, 
            Remarks = input$remarksID), 
          row.names = 1L, class = "data.frame") 

    output$tableID <- renderTable({outputTable}) 
    }) 
} 

ui.R

jsCode<-"shinyjs.FillRemarks = function(remarks){document.getElementById('remarksID').value = remarks}" 
jsCode2<-"shinyjs.updateRemarks = function(val){ Shiny.onInputChange('remarksID', val); }" 

record <- structure(list(ID = "x1y2z3", 
         Country = "Netherlands", 
         Remarks = "Bla bla bla bla bla bla bla bla bla bla bla"), 
        .Names = c("ID","Country", "Remarks"), 
        class = "data.frame", row.names = 1L) 


ui <- shinyUI(fluidPage(mainPanel(
    useShinyjs(), 
    extendShinyjs(text = jsCode), 
    extendShinyjs(text = jsCode2), 
    fluidRow( 
    br(), 
    column(2, selectInput("selectID",label = "Select ID:", choices = record$ID, selected = record$ID)), 
    br(),br(),br(),hr() 
), 
    fluidRow( column(12, textInput("textID",label = "Country:") ) ), 
    fluidRow( column(3, tags$p(id="remarksLabelID","Remarks:"), tags$textarea(id="remarksID", rows=3, cols=40, "") ), 
    tags$style(type='text/css', "#remarksLabelID { 
       display: inline-block; 
       max-width: 100%; 
       margin-bottom: 5px; 
       font-weight: 700; 
       }"), 
    tags$style(type='text/css', "#remarksID { 
       resize: none; 
       width: 100%; 
       display: block; 
       padding: 6px 12px; 
       font-size: 14px; 
       line-height: 1.42857143; 
       color: #555; 
       background-color: #fff; 
       background-image: none; 
       border: 1px solid #ccc; 
       border-radius: 4px; 
       }") 


    ), 
    fluidRow(actionButton("button", "An action button")), 
    fluidRow( 

    hr(), 
    column(12, 

      titlePanel("Preview"), 

      tableOutput("tableID") 
    ) 
) 

)))