r - Shiny R 应用程序让用户通过套索选择修改数据框

Question

我创建了一个 R Shiny 应用程序来帮助我简化处理高维化学成分数据的一些常见数据清理任务。具体来说，这个应用程序使用fluidPage 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 中与响应式语句相关的工作，我就能够按照我最初的预期工作。这个应用程序现在几乎可以完成我想要它做的所有事情，尽管我觉得此时代码真的只是拼凑在一起，需要在许多方面进行修复。特别是我有一个非常笨拙的解决方案来在我的原始数据框中查找所选项目，因为我真的不喜欢曲线编号/点编号索引系统。

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