Question

我一直在尝试开发一个Shiny应用程序来执行以下操作：

使用以下结构输入数据集：名为weekna的列，其中包含xaxis标签和可变数量的列，这些列具有不同的值，具有不同的值。

我的目标是，对于每个有值的列，交互式地要求用户选择两个点，一个叫做第一个，另一个叫做最后一个。

当用户结束输入点数时，进行一些计算并打印一些结果。

其他功能： - 每次用户选择一个点时，它都会在图中着色（红色表示第一个，蓝色表示最后一个）。

我的意图是：

显示第一列的图表，允许选择第一个，最后一个点。
在图表中使用不同的颜色绘制每个点。
将它们打印在情节下方的摘要表中。
显示一个名为“下一个情节”的按钮，转到第二列并重复该过程直到最后一个完成。
或者，使用“上一个/下一个”按钮前进/后退。
或者，使用带有不同列的不同图表的tabset。
有一个显示结果的最终“过程”按钮。

到目前为止我的工作：我已经完成了将所有图形绘制在同一帧中（不是每个绘图的一个帧）并放置了一个带有结果的最终表格（在这种情况下为了简化事情，我刚刚安排了点并显示用户点击的内容）。我试图着色点，但似乎它不记得以前的选择。另外，我复制了每个图表，因为我不知道如何从同一个图表中获得两个点。

欢迎任何（或所有）问题的任何帮助。

library(ggplot2)
library(shiny)

ui <- fluidPage(
  uiOutput("maintab"),
  fluidRow(
    column(width = 12,
           tableOutput("results_final")
    )
  )
)

server <- function(input, output) {

  inputdata<-data.frame(weekna=letters[1:20])
  inputdata$weekno=1:NROW(inputdata)
  inputdata$normal<-dnorm(inputdata$weekno,10)
  inputdata$beta<-dbeta(inputdata$weekno, 1, 1)
  inputdata$gamma<-dgamma(inputdata$weekno, 1, 1)
  inputdata$logistic<-dlogis(inputdata$weekno,10)
  inputdata$poisson<-dpois(inputdata$weekno, 2)
  namescol<-names(inputdata)[-(1:2)]
  nnamescol<-length(namescol)
  for (s in namescol) eval(parse(text=paste0("inputdata$'",s,"_color'<-'1'")))

  makeReactiveBinding('inputdata')

  output$maintab <- renderUI({
    fluidRow(
      do.call(column, c(width=6,
                        c(
                          lapply(namescol,function(s){
                            call("plotOutput", outputId=paste0("plot_",as.character(s),"_first"),
                                 height = 300, click = paste0("plot_",as.character(s),"_first_click"))
                          }),
                          lapply(namescol,function(s){
                            call("tableOutput", outputId=paste0("results_",as.character(s),"_first"))
                          })
                        )[c(rbind(1:nnamescol,1:nnamescol+nnamescol))]

      )),
      do.call(column, c(width=6,
                        c(
                          lapply(namescol,function(s){
                            call("plotOutput", outputId=paste0("plot_",as.character(s),"_last"),
                                 height = 300, click = paste0("plot_",as.character(s),"_last_click"))
                          }),
                          lapply(namescol,function(s){
                            call("tableOutput", outputId=paste0("results_",as.character(s),"_last"))
                          })
                        )[c(rbind(1:nnamescol,1:nnamescol+nnamescol))]

      ))
    )
  })

  lapply(namescol, function(s){output[[paste0("plot_",as.character(s),"_first")]] <- renderPlot({
    ggplot(inputdata, aes_string("weekno", s, color=paste0(s,"_color"))) + geom_point() + geom_line(color="#000000") +
      scale_x_continuous(breaks=inputdata$weekno, labels = inputdata$weekna)+
      labs(title = s, x = "week", y = "rate")
  })})

  lapply(namescol, function(s){output[[paste0("plot_",as.character(s),"_last")]] <- renderPlot({
    ggplot(inputdata, aes_string("weekno", s, color=paste0(s,"_color"))) + geom_point() + geom_line(color="#000000") +
      scale_x_continuous(breaks=inputdata$weekno, labels = inputdata$weekna)+
      labs(title = s, x = "week", y = "rate")
  })})

  lapply(namescol,function(s){
    observeEvent(input[[paste0("plot_",as.character(s),"_first_click")]], {
      np <- nearPoints(inputdata, input[[paste0("plot_",as.character(s),"_first_click")]], maxpoints=1 , threshold = 1000)
      output[[paste0("results_",as.character(s),"_first")]] <- renderTable({
        data.frame(var1=s,np[c("weekno","weekna",s)],stringsAsFactors=F)
      })
      inputdata[,paste0(as.character(s),"_color")] <<- rep("1",length(inputdata$weekno))
      inputdata[inputdata$weekno==np$weekno,paste0(as.character(s),"_color")] <<- "2"

      output$results_final <- renderTable({
        out1<-data.frame()
        for (s in namescol){
          sname<-paste0("plot_",as.character(s),"_first_click")
          np<-nearPoints(inputdata, input[[sname]], addDist = F, threshold=1000, maxpoints=1)
          if (NROW(np)==0){
            out1x<-as.data.frame(t(rep(NA,4)),stringsAsFactors=F)
          }else{
            out1x<-data.frame(var1=s,np[c("weekno","weekna",s)],stringsAsFactors=F)
          }
          names(out1x)<-c("var1","weekno_first","weekna_first","value_first")
          out1<-rbind(out1,out1x)
        }
        out2<-data.frame()
        for (s in namescol){
          sname<-paste0("plot_",as.character(s),"_last_click")
          np<-nearPoints(inputdata, input[[sname]], addDist = F, threshold=1000, maxpoints=1)
          if (NROW(np)==0){
            out2x<-as.data.frame(t(rep(NA,4)),stringsAsFactors=F)
          }else{
            out2x<-data.frame(var1=s,np[c("weekno","weekna",s)],stringsAsFactors=F)
          }
          names(out2x)<-c("var1","weekno_last","weekna_last","value_last")
          out2<-rbind(out2,out2x)
        }
        out3<-data.frame(var1=namescol)
        outf<-merge(out3,out1,all.x=T, by="var1")
        outf<-merge(outf,out2,all.x=T, by="var1")
        outf
      })

    })
  })

  lapply(namescol,function(s){
    observeEvent(input[[paste0("plot_",as.character(s),"_last_click")]], {
      np <- nearPoints(inputdata, input[[paste0("plot_",as.character(s),"_last_click")]], maxpoints=1 , threshold = 1000)
      output[[paste0("results_",as.character(s),"_last")]] <- renderTable({
        data.frame(var1=s, np[c("weekno","weekna",s)],stringsAsFactors=F)
      })
      inputdata[,paste0(as.character(s),"_color")] <<- rep("1",length(inputdata$weekno))
      inputdata[inputdata$weekno==np$weekno,paste0(as.character(s),"_color")] <<- "3"

      output$results_final <- renderTable({
        out1<-data.frame()
        for (s in namescol){
          sname<-paste0("plot_",as.character(s),"_first_click")
          np<-nearPoints(inputdata, input[[sname]], addDist = F, threshold=1000, maxpoints=1)
          if (NROW(np)==0){
            out1x<-as.data.frame(t(rep(NA,4)),stringsAsFactors=F)
          }else{
            out1x<-data.frame(var1=s,np[c("weekno","weekna",s)],stringsAsFactors=F)
          }
          names(out1x)<-c("var1","weekno_first","weekna_first","value_first")
          out1<-rbind(out1,out1x)
        }
        out2<-data.frame()
        for (s in namescol){
          sname<-paste0("plot_",as.character(s),"_last_click")
          np<-nearPoints(inputdata, input[[sname]], addDist = F, threshold=1000, maxpoints=1)
          if (NROW(np)==0){
            out2x<-as.data.frame(t(rep(NA,4)),stringsAsFactors=F)
          }else{
            out2x<-data.frame(var1=s,np[c("weekno","weekna",s)],stringsAsFactors=F)
          }
          names(out2x)<-c("var1","weekno_last","weekna_last","value_last")
          out2<-rbind(out2,out2x)
        }
        out3<-data.frame(var1=namescol)
        outf<-merge(out3,out1,all.x=T, by="var1")
        outf<-merge(outf,out2,all.x=T, by="var1")
        outf
      })

    })
  })

}

shinyApp(ui, server)

编辑：

今天我一直在思考我的问题而且我有一个计划：

创建两个必须具有反应性的数据集（使用makereactivebinding），并且可以交互式更新。

plotdataset：与原始数据集的每一列的另一列输入相同，称为原始加_color。

clickdataset：一个data.frame，用于存储所有图表中的所有点击以及点击完成的时间。

计划是：

使用plotdataset绘制每个原始列以及相应的_color列，以两种不同的颜色绘制两个点（名称为红色/绿色）使用tabsetpanel绘制一组面板，每个面板都有不同的列。

每次用户点击任何内容时，点击的点都会添加rbind到clickdataset。

选择clickdataset中每列最新的两个点击点，并命令它们找出第一个/最后一个点。

使用此信息更新plotdataset _color列，以便第一个为“红色”，最后一个为“绿色”，以便更新所有绘图。

选择每列最新的两个点击点，如果用户不喜欢选择，则允许用户点击三次，每次点击最多两次。

现在是时候考虑如何实施我的计划了。

Answer 1

我刚刚编写了我今天早上概述的内容，作为解决此问题的计划。

这是结果，通过这个程序，我可以从单个图中获得任意数量的点。

我通过不允许输入数据集具有可变数量的列来简化问题（我已经做了一个只有两列的示例），但是为了使这个例子适应更一般的情况应该很容易看到我的原始代码。

library(ggplot2)
library(shiny)
library(shinydashboard)

inputdata<-data.frame(weekno=1:20, weekna=letters[1:20])
inputdata$normal<-dnorm(inputdata$weekno,10)
inputdata$beta<-dbeta(inputdata$weekno, 1, 1)
inputdata$gamma<-dgamma(inputdata$weekno, 1, 1)
inputdata$logistic<-dlogis(inputdata$weekno,10)
inputdata$poisson<-dpois(inputdata$weekno, 2)

tail.order<-function(i.data, i.n, i.order){
  res<-tail(i.data, n=i.n)
  res<-res[order(res[i.order]),]
  res$id.tail<-1:NROW(res)
  res
}

extract.two<-function(i.data, i.order, i.column){
  data<-unique(i.data, fromLast=T)
  results <- do.call("rbind", by(data, data[i.column], tail.order, i.n=2, i.order=i.order))
  return(results)
}

ui <- fluidPage(
  uiOutput("maintab")
)

server <- function(input, output) {
  origdata<-inputdata[c("weekno","weekna","normal","poisson")]
  plotdata<-origdata
  namescol<-names(plotdata)[-(1:2)]
  nnamescol<-length(namescol)
  for (s in namescol) eval(parse(text=paste0("plotdata$'",s,"_color'<-'1'")))

  values <- reactiveValues(plotdata = plotdata, clickdata=data.frame())

  output$maintab <- renderUI({
    tabsetPanel(tabPanel("normal", plotOutput("plot_normal"
                                              , click = paste0("plot_normal_click")
    )),
    tabPanel("poisson", plotOutput("plot_poisson"
                                   , click = paste0("plot_poisson_click")
    )),
    tabPanel("results",tableOutput("results")),
    tabPanel("resultsfull",tableOutput("resultsfull"))
    )
  })

  output$plot_normal <- renderPlot({
    ggplot(values$plotdata, aes_string("weekno", "normal")) +
      geom_point(aes_string("weekno", "normal", color="normal_color")) +
      scale_color_manual(values = c("1" = "grey", "2" = "red", "3" = "green")) +
      geom_line(aes_string("weekno", "normal"), color="#000000") +
      scale_x_continuous(breaks=origdata$weekno, labels = origdata$weekna)+
      labs(title = s, x = "week", y = "rate")
  })

  output$plot_poisson <- renderPlot({
    ggplot(values$plotdata, aes_string("weekno", "poisson")) +
      geom_point(aes_string("weekno", "poisson", color="poisson_color")) +
      scale_color_manual(values = c("1" = "grey", "2" = "red", "3" = "green")) +
      geom_line(aes_string("weekno", "poisson"), color="#000000") +
      scale_x_continuous(breaks=origdata$weekno, labels = origdata$weekna)+
      labs(title = s, x = "week", y = "rate")
  })

  output$results<-renderTable({
    if (NROW(values$clickdata)>0) extract.two(values$clickdata,"weekno","variable")
  })

  output$resultsfull<-renderTable({
    values$clickdata
  })

  observeEvent(input$plot_normal_click, {
    np <- nearPoints(origdata, input$plot_normal_click, maxpoints=1 , threshold = 1000)
    values$clickdata<-rbind(values$clickdata,data.frame(variable="normal", np, stringsAsFactors = F))
    if (NROW(values$clickdata)>0){
      p0<-extract.two(values$clickdata,"weekno","variable")
      p1<-subset(p0, variable=="normal" & id.tail==1)
      p2<-subset(p0, variable=="normal" & id.tail==2)
      if (NROW(p1)>0) {
        values$plotdata[values$plotdata["normal_color"]=="2","normal_color"]<-"1"
        values$plotdata[origdata$weekno==p1$weekno,"normal_color"]<-"2"
      }
      if (NROW(p2)>0){
        values$plotdata[values$plotdata["normal_color"]=="3","normal_color"]<-"1"
        values$plotdata[origdata$weekno==p2$weekno,"normal_color"]<-"3"
      }
    }
  })

  observeEvent(input$plot_poisson_click, {
    np <- nearPoints(origdata, input$plot_poisson_click, maxpoints=1 , threshold = 1000)
    values$clickdata<-rbind(values$clickdata,data.frame(variable="poisson", np, stringsAsFactors = F))
    if (NROW(values$clickdata)>0){
      p0<-extract.two(values$clickdata,"weekno","variable")
      p1<-subset(p0, variable=="poisson" & id.tail==1)
      p2<-subset(p0, variable=="poisson" & id.tail==2)
      if (NROW(p1)>0) {
        values$plotdata[values$plotdata["poisson_color"]=="2","poisson_color"]<-"1"
        values$plotdata[origdata$weekno==p1$weekno,"poisson_color"]<-"2"
      }
      if (NROW(p2)>0){
        values$plotdata[values$plotdata["poisson_color"]=="3","poisson_color"]<-"1"
        values$plotdata[origdata$weekno==p2$weekno,"poisson_color"]<-"3"
      }
    }
  })
}

shinyApp(ui, server)

从一组变量图

1 个答案: