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

Question

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

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

我发现问题的答案链接 here quite 很有用，但我仍然没能成功。下面是我当前的应用程序脚本和现在输出的屏幕截图。

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

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

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

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

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

Shiny R Application to let users modify dataframe by lasso selection

r

shiny

r-plotly