Shiny R Application to let users modify dataframe by lasso selection

Question

I've created an R Shiny application to help me streamline some common data cleaning tasks for working with high dimensional chemical composition data. Specifically, this app uses the fluidPage ui and ggplot/plotly interface to create a biplot with user selected X and Y variables and color/symbol attributes. The event_data function allows users to see attributes associated with points they interactively select via the rectangular selection or lasso. I'm new to Shiny so the code is not very elegant but I've managed to do all of the above.

I'm hoping to add one additional feature and I'm stuck on the best way to approach this. Specifically I'd like to be able to change one field in the dataset for points that are currently selected on a given plot. My current idea is to have a text field input that will allow me to type in what I'd like the new value in the field and have the change execute with an actionButton.

I found the answers to the question linked here quite useful but I still haven't managed to get this to work. Below is my current application script and a screenshot of the output as it stands now.

Any help or suggestions for new approaches would be greatly appreciated.

library(plotly)
library(shiny)
library(knitr)
library(kableExtra)


myApp <- function(attributes,dat1) {

dataset <- cbind(attributes,dat1)

ui <- fluidPage(
  plotlyOutput('plot', width='1000px', height='600px'),
  fluidRow(
      column(2,
          selectInput('xvar','X',names(dat1)),
          selectInput('yvar','Y',names(dat1))),
      column(3,offset=0.5,
      selectInput('Code','GROUP',names(attributes)),
      checkboxInput('Conf','Confidence Hull',value=TRUE)),
  column(3,offset=0.5,
      actionButton('Change','Change Group Assignment'),
      textInput('NewGroup', label = 'Enter new group designation')),
  column(3,offset=0.5,
         actionButton("exit", label = "Return to R and write data"))),
  verbatimTextOutput('brush')
)

server <- function(input, output) {

  data.sel <- reactive({
    dataset[,c(input$xvar,input$yvar,input$Code)]
  })

  output$plot <- renderPlotly({
    p <- ggplot(data.sel(), aes(x=data.sel()[,1], y=data.sel()[,2], 
         color=data.sel()[,3], shape=data.sel()[,3])) + 
      geom_point() +
      labs(x=input$xvar,y=input$yvar) 
      if(input$Conf) {p <- p + stat_ellipse(level=0.95)}
    ggplotly(p) %>% layout(dragmode = 'select')
  })

  output$brush <- renderPrint({
    d <- event_data('plotly_selected')
    dd <- round(cbind(d[[3]],d[[4]]),3)
    vv <- attributes[which(round(data.sel()[,1],3) %in% dd[,1] & 
    round(data.sel()[,2],3) %in% dd[,2]),]
    if (is.null(d)) 'Click and drag events (i.e., select/lasso) appear here 
(double-click to clear)' else kable(vv)
  })

    observe({
    if(input$exit > 0)
      stopApp()})

  }

runApp(shinyApp(ui, server))
return(dataset)
}

In order to test this you can use a modified version of the iris data as I show below. Essentially, I'd like to be able to change the text in the new variable I'm adding to the iris data.

iris2 <- cbind(iris,rep('A',150))
names(iris2)[6] <- 'Assignment'
myApp(iris2[,5:6],iris2[,-(5:6)])

Here is a screenshot of the app in action. I've included the buttons to go along with my proposed solution but they currently do nothing.

Screenshot:

Matt Peeples Matt Peeples · Accepted Answer · 2018-03-27T04:20:04

I was able to get this working as I originally intended once I understood how scoping assignment works in Shiny in relation to reactive statements. This app now mostly does everything I want it do, though I feel the code is really just cobbled together at this point and needs to be fixed in many areas. In particular I have a very janky solution to finding the selected items in my original dataframe as I really don't like the curvenumber/pointnumber index system.

library(plotly)
library(shiny)
library(knitr)
library(kableExtra)

theme_set(theme_light())


myApp <- function(attributes,dat1) {

dataset <- cbind(attributes,dat1)
vv <- NULL

ui <- fluidPage(
  plotlyOutput('plot', width='1000px', height='600px'),
  fluidRow(
  column(2,
      selectInput('xvar','X',names(dat1),selected='cs'),
      selectInput('yvar','Y',names(dat1),selected='ta')),
  column(3,offset=0.5,
      selectInput('Code','GROUP',names(attributes),selected='CORE'),
      checkboxInput('Conf','Confidence Elipse',value=TRUE),
      sliderInput('int.set','Set Confidence Interval',min=0.80,max=0.99,step=0.01,value=0.95)),
  column(3,offset=0.5,
      br(),
      actionButton('Change','Change Group Assignment'),
      textInput('NewGroup', label = 'Enter new group designation')),
  column(3,offset=0.5,
      br(),
      actionButton('refresh', label='Refresh Plot with New Assignments'),
      br(),br(),
      actionButton("exit", label = "Return to R and write data"))),
  verbatimTextOutput('brush')
)



server <- function(input, output) {

  values <- reactiveValues(vv = NULL)

  data.sel <- reactive({
    dataset[,c(input$xvar,input$yvar,input$Code)]
  })


  output$plot <- renderPlotly({
    g1 <- data.sel()
    p <- ggplot(g1, aes(x=g1[,1], y=g1[,2], color=g1[,3], shape=g1[,3])) + 
      geom_point() +
      labs(x=input$xvar,y=input$yvar,color=input$Code,shape=input$Code) 
      if(input$Conf) {p <- p + stat_ellipse(level=input$int.set)}
    ggplotly(p) %>% layout(dragmode = 'select')
  })


  output$brush<- renderPrint({
    g1 <- data.sel()
    d <- event_data('plotly_selected')
    dd <- round(cbind(d[[3]],d[[4]]),3)
    vv <- attributes[which(round(g1[,1],3) %in% dd[,1] & round(g1[,2],3) %in% dd[,2]),]
    vv <<- vv
    if (is.null(vv)) "Click and drag events (i.e., select/lasso) appear here (double-click to clear)" else kable(vv)
  })

  observeEvent(input$Change > 0, {
  if (!is.null(vv)) {
    dataset[which(row.names(dataset) %in% row.names(vv)),]$CORE <<- 
input$NewGroup
      }})

  observe({
  if(input$exit > 0)
  stopApp()})

  }

runApp(shinyApp(ui, server))
return(dataset)
}

And some test data

data(iris)

iris2 <- cbind(iris,rep('a',nrow(iris)))
names(iris2)[6] <- 'CORE'

out <- myApp(iris2[,5:6],iris2[,1:4])

Shiny R Application to let users modify dataframe by lasso selection

1 Answers