Can Shiny recognise text selection with mouse (highlighted text)?

Question

I need the user to assign text fragments to categories or "codes" in Shiny. Basically, I would like the user to highlight a text from an output (in the example below, from a table or text output), then press a button (code) and assign the selected text to an object within the app. In the app below, the selected text should be rendered as output$selected_text. I would appreciate any suggestions on how to achieve this, I suspect JavaScript would be helpful.

library(shiny)

text1 <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Fusce nec quam ut tortor interdum pulvinar id vitae magna. Curabitur commodo consequat arcu et lacinia. Proin at diam vitae lectus dignissim auctor nec dictum lectus. Fusce venenatis eros congue velit feugiat, ac aliquam ipsum gravida. Cras bibendum malesuada est in tempus. Suspendisse tincidunt, nisi non finibus consequat, ex nisl condimentum orci, et dignissim neque est vitae nulla." 
text2 <- "Aliquam ut purus neque. Maecenas justo orci, semper eget purus eu, aliquet molestie mi. Duis convallis ut erat at faucibus. Quisque malesuada ante elementum, tempor felis et, faucibus orci. Praesent iaculis nisi lorem, non faucibus neque suscipit eu. Ut porttitor risus eu convallis tristique. Integer ac mauris a ex maximus consequat eget non felis. Pellentesque quis sem aliquet, feugiat ligula vel, convallis sapien. Ut suscipit nulla leo"

ui <- bootstrapPage(
  fluidRow(
    column(4,
           tags$h1("Text to code"),
           tags$h2("From table"),
           tableOutput("table"),
           tags$h2("From raw text"),
           verbatimTextOutput("text")
    ),
    column(4,
           tags$h1("Coding options"),
           actionButton("code1", "Assign selected text to Code1"),
           tags$h1("Code1 output"),
           verbatimTextOutput("selected_text")
    )
  )
)


server <- function(input, output) {
  output$table <- renderTable({
    data.frame(paragraph = 1:2, text = c(text1, text2))
  })

  output$text <- renderText(paste(text1, text2))
}

shinyApp(ui = ui, server = server)

Answer 1

Yes, it can.
javascript is indeed useful for this, not sure if it's necessary, but it is certainly easier.

I based my answer on this answer to get the highlighted text in js and this answer to send the data from js to R, so credit is to the original author.

Simple reproducible code first, then I'll explain what's going on:

server.R

shinyServer(function(input, output, session) {

    output$results = renderPrint({
        input$mydata
    })

})

ui.R

shinyUI(bootstrapPage(

    # a div named mydiv
    div(id="mydiv", "SOME text here"),

    # a shiny element to display unformatted text
    verbatimTextOutput("results"),

    # javascript code to send data to shiny server
    tags$script('
                function getSelectionText() {
                    var text = "";
                    if (window.getSelection) {
                        text = window.getSelection().toString();
                    } else if (document.selection) {
                        text = document.selection.createRange().text;
                    }
                    return text;
                }

        document.onmouseup = document.onkeyup = document.onselectionchange = function() {
            var selection = getSelectionText();
            Shiny.onInputChange("mydata", selection);
        };
        ')
))

Server.R is simple enough that does not need explanation, we simply render the content of input$mydata.

The juice happens in ui.R where we have three elements:

• A div element (with id='mydiv')
• A text output that render the result from server.R
• A script tag, that contains the javascript we need.

Inside the script tag, we first have a function that gets the selection. This is a copy of the js answer (with the exception that I got an error when the js contains && logical operator, that somehow gets translated badly)

This function is called onmouseup, onkeyup and onselectionchange, and its result assigned to selection.

---

Finally and probably the important bit, the js function Shiny.onInputChange("mydata", selection) assign the content of js's selection variable to mydata R's variable.

---

Hope this helps

Answer 2

Thanks to @GGamba, I could develop the following answer for my given example:

library(shiny)

text1 <- "Lorem ipsum dolor sit amet, consectetur adipiscing elit. Fusce nec quam ut tortor interdum pulvinar id vitae magna. Curabitur commodo consequat arcu et lacinia. Proin at diam vitae lectus dignissim auctor nec dictum lectus. Fusce venenatis eros congue velit feugiat, ac aliquam ipsum gravida. Cras bibendum malesuada est in tempus. Suspendisse tincidunt, nisi non finibus consequat, ex nisl condimentum orci, et dignissim neque est vitae nulla." 
text2 <- "Aliquam ut purus neque. Maecenas justo orci, semper eget purus eu, aliquet molestie mi. Duis convallis ut erat at faucibus. Quisque malesuada ante elementum, tempor felis et, faucibus orci. Praesent iaculis nisi lorem, non faucibus neque suscipit eu. Ut porttitor risus eu convallis tristique. Integer ac mauris a ex maximus consequat eget non felis. Pellentesque quis sem aliquet, feugiat ligula vel, convallis sapien. Ut suscipit nulla leo"
highlight <- '
                function getSelectionText() {
var text = "";
if (window.getSelection) {
text = window.getSelection().toString();
} else if (document.selection) {
text = document.selection.createRange().text;
}
return text;
}

document.onmouseup = document.onkeyup = document.onselectionchange = function() {
var selection = getSelectionText();
Shiny.onInputChange("mydata", selection);
};
'

coded_text <- character(0)

ui <- bootstrapPage(
  tags$script(highlight),
  fluidRow(
    column(4,
           tags$h1("Text to code"),
           tags$h2("From table"),
           tableOutput("table"),
           tags$h2("From raw text"),
           verbatimTextOutput("text")
    ),
    column(4,
           tags$h1("Coding options"),
           actionButton("code1", "Assign selected text to Code1"),
           tags$h1("Code1 output"),
           verbatimTextOutput("selected_text")
    )
  )
)


server <- function(input, output) {
  output$table <- renderTable({
    data.frame(paragraph = 1:2, text = c(text1, text2))
  })

  output$text <- renderText(paste(text1, text2))

  coded <- eventReactive(input$code1, {
    coded_text <<- c(coded_text, input$mydata)
    coded_text
  })

  output$selected_text <- renderPrint({
    coded()
  })

}

shinyApp(ui = ui, server = server)