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

时间:2018-03-24 07:36:36

标签: r shiny r-plotly

我创建了一个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)])

以下是该应用的截图。我已经包含了按钮以配合我提出的解决方案,但他们目前什么也没做。

截图:

Screenshot

1 个答案:

答案 0 :(得分:1)

一旦我理解了Shiny中的作用域分配在被动语句方面的作用,我能够按照我原先的意图使用它。这个应用程序现在主要做我想做的一切,虽然我觉得代码实际上只是拼凑在一起,需要在许多方面修复。特别是我有一个非常笨拙的解决方案来查找原始数据框中的所选项目,因为我真的不喜欢curvenumber / pointnumber索引系统。

text = get_object_or_404(Text, pk = pk_of_TEXT_instance)

和一些测试数据

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