2

I have a shiny application where I want to be able to edit data which is in a database. In my application I select a ID and retrieve the corresponding data. (in the example "record") This data is filled in into different shiny widgets to be able to edit them. (in the example below "textID" and "remarksID") After editing and pressing a submit button the data in the database will be updated.

This does not sound very complicated, and when using normal shiny widgets it is not. But I am using a special handmade input widget (inspired by the following SO answer: How to create TextArea as input in a Shiny webapp in R?). By using javascript i can fill in the handmade input widget. But in one way or another it does not get recognized as an input value, it is only visualized in the screen. When editing the handmade input widget it will be recognized as an input value.

Still this not seems to be a big problem. But suppose that I do not want to change the handmade input value and I change other input values and submit the edit. Then the handmade input value will changed in to an empty string.

The shiny application below shows the problem. The visualized input of the remarks input widget is not visible by default, only when edited, in result. (which will be send back to the database)

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)

Am I close to the solution or am I thinking in the wrong direction? Also can not come up with a good title for this question

Community
  • 1
  • 1
Berecht
  • 1,085
  • 9
  • 23
  • I have seen other examples where javascript modified input values (even for standard input types) are not picked up by Shiny server end. I think you'll need to use the techniques here https://ryouready.wordpress.com/2013/11/20/sending-data-from-client-to-server-and-back-using-shiny/ to explicitly send the values to server. – Xiongbing Jin Jun 13 '16 at 14:36

1 Answers1

2

I am not completely sure if I have understood you right, but even though I will try to answer.

  1. Regarding the submit button you have to take into account that when a submitButton is present in a Shiny application, it causes ALL the inputs on the page to not send updates to the server UNTIL the button is pressed. That is to say, that when you press it ALL inputs will be sent back to the server. In your case it is best not to use submitButton, but instead to use actionButton, since it allows finer-grained control over which inputs will trigger re-execution of code.

  2. I have modified your snippet, including also an action button and appending one more line of javascript which updates the remarksID variable value so it's not empty the first time you run it. I think it works as you wish now.

The JS line you have to add to the ui is jsCode2<-"shinyjs.updateRemarks = function(val){ Shiny.onInputChange('remarksID', val); }" It will update remarksID on the server. It needs to be done like this, because it is an input that has been modified programatically. Thank Shiny reactive model for this.

Then:

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

In server.R you have to use it here: 

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

Finally, you have to add this also to server.R in order to use the action button.

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

The complete snippets are:

Server.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")
    )
  )

  )))
Leonardo Lanchas
  • 1,616
  • 1
  • 15
  • 37