闪亮的 R 应用程序让用户通过套索选择修改数据框

Question

我创建了一个 R Shiny 应用程序来帮助我简化一些常见的数据清理任务，以处理高维化学成分数据。具体来说，此应用程序使用流体页面 ui 和 ggplot/plotly 界面来创建具有用户选择的 X 和 Y 变量以及颜色/符号属性的双标图。 event_data 函数允许用户查看与他们通过矩形选择或套索交互选择的点相关联的属性。我是 Shiny 的新手，所以代码不是很优雅，但我已经设法完成了上述所有操作。

我希望添加一项附加功能，但我一直坚持采用最佳方法来解决此问题。具体来说，我希望能够为当前在给定图上选择的点更改数据集中的一个字段。我目前的想法是有一个文本字段输入，允许我在字段中输入我想要的新值并使用 actionButton 执行更改。

我发现链接here 的问题的答案非常有用，但我仍然没有设法让它发挥作用。以下是我当前的应用程序脚本和当前输出的屏幕截图。

对于新方法的任何帮助或建议将不胜感激。

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)
}

为了测试这一点，您可以使用如下所示的虹膜数据的修改版本。本质上，我希望能够更改要添加到虹膜数据的新变量中的文本。

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

这是运行中的应用程序的屏幕截图。我已经包含了与我提出的解决方案一起使用的按钮，但它们目前什么都不做。

截图：

Answer 1

一旦我了解了 Shiny 中与反应式语句相关的范围分配如何工作，我就能够按照我最初的预期工作。这个应用程序现在几乎可以完成我想要它做的所有事情，尽管我觉得此时代码实际上只是拼凑在一起，需要在许多领域进行修复。特别是我有一个非常笨拙的解决方案来在我的原始数据框中找到选定的项目，因为我真的不喜欢 curvenumber/pointnumber 索引系统。

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)
}

还有一些测试数据

data(iris)

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

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