1

我不确定如何问这个问题，但它是这样的：

我在 R 中使用了闪亮的包。我目前正在输出一个 ggplot2 图，这很好。

我想绘制两个图表，一个在另一个之上，以直观地比较它们之间的差异。

理想情况下，我希望能够使用单选按钮选择绘图位置（顶部或底部）。当我更改输入以生成我现在已经得到的绘图时，它会出现在顶部/底部单选按钮选择的任何位置。

trim_down<-function(LAB,TYPE,FORM,CLASS,AMI,DATE){

  ma<<-dft
  if (is.nan(TYPE)==FALSE){ma<<-subset(ma, type %in% TYPE)}
  if (is.nan(FORM)==FALSE){ma<<-subset(ma, form %in% FORM)}
  if (is.nan(CLASS)==FALSE){ma<<-subset(ma, class %in% CLASS)}
  if (is.nan(AMI)==FALSE){ma<<-subset(ma, ami %in% AMI)}

  ma<<-subset(ma, as.Date(dateStarted,"%m/%d/%Y")>=DATE[1]  )
  ma<<-subset(ma, as.Date(dateStarted,"%m/%d/%Y")<=DATE[2]  )
  dim(ma)
  ma<<-ma[,-(1:length(test_factors))]
  all_test_names<<-names(ma)
  ma<<-as.matrix(ma)
  ma<<-t(apply(ma, 1,as.numeric,na.rm=TRUE))
  aa<<-1-colMeans(ma,na.rm=TRUE)
  b<<-colSums(!is.na(ma))
  active_test_names<<-all_test_names[!is.nan(aa)]
  x<<-rbind(aa,b)
  graph.me(x,all_test_names,active_test_names,trimmed_up=FALSE)
 }




graph.me<-function(x,all_test_names,active_test_names,trimmed_up=TRUE){
  library(reshape2)
  aa<<-x[1,]
  b<<-x[2,]
  aa[aa==0]=-.1
  aa[is.na(aa)]=0
  XAXIS<<-all_test_names
  success <- as.data.frame(aa)
  rownames(success)<-XAXIS
  samples <- as.data.frame(b)
  data.long <- cbind(melt(success,id=1), melt(samples, id=1))

  names(data.long) <- c("success", "count")
  rownames(data.long)<-XAXIS


  threshold <- 25
  data.long$fill <- with(data.long,ifelse(count>threshold,max(count),count))
  data.long$fill[data.long$fill>threshold]<-threshold

  library(ggplot2)
  library(RColorBrewer)
  print(ggplot(data.long) +
    geom_bar(aes(x=XAXIS, y=success, fill=fill),colour="grey70",stat="identity")+
    scale_fill_gradientn(colours=brewer.pal(9,"RdYlGn")) +
    theme(axis.text.x=element_text(angle=-90,hjust=0,vjust=0.4)))

}
   ui.r
 library(shiny)

    # Define UI for miles per gallon application
    shinyUI(pageWithSidebar(

      # Application title
      headerPanel("Example"),


      sidebarPanel(
    #    checkboxGroupInput("_lab", "lab:",unique(dft$lab)),
        checkboxGroupInput("type", "Type:",unique(dft$type),selected=unique(dft$type)),
        checkboxGroupInput("form", "Form:",unique(dft$form),selected=unique(dft$form)),
        checkboxGroupInput("class", "Class:",unique(dft$class),selected=unique(dft$class)),
        checkboxGroupInput("ami", "AMI:",unique(dft$ami),selected=unique(dft$ami)),
        dateRangeInput("daterange", "Date range:",
                       start = min(as.Date(dft$date,"%m/%d/%Y")),
                       end   = max(as.Date(dft$date,"%m/%d/%Y")))

      ),

      mainPanel(
        h3(textOutput("caption")),

        plotOutput("Plot")
      )
    ))


server.r
library(shiny)



shinyServer(function(input, output) {

  # Compute the forumla text in a reactive expression since it is 
  # shared by the output$caption and output$mpgPlot expressions
  formulaText <- reactive({
    paste(input$type,input$form,input$class,input$ami)
  })



  # Return the formula text for printing as a caption
  output$caption <- renderText({
    formulaText()
  })

  # Generate a plot of the requested variable against mpg and only 
  # include outliers if requested
  output$Plot <- renderPlot(function(){

    print(trim_down(NA,input$type,input$form,input$class,input$ami,input$daterange))
    })
})

感谢您的帮助...抱歉有这么多代码，但我不确定在每个人的审查中省略什么是安全的。如果有帮助，我觉得可以通过解决 ggplot 在一些布局网格上绘图来解决问题......就像，grid.arrange()这是由顶部或底部的单选按钮驱动的？

根据回复，我试过这个：

ui.r
library(shiny)

shinyUI(pageWithSidebar(

  # Application title
  headerPanel("Example"),


  sidebarPanel(
    radioButtons("plotSpot", "Position", c(1,2)),
    checkboxGroupInput("type", "Type:",unique(dft$type),selected=unique(dft$type)),
    checkboxGroupInput("form", "Form:",unique(dft$form),selected=unique(dft$form)),
    checkboxGroupInput("class", "Class:",unique(dft$class),selected=unique(dft$class)),
    checkboxGroupInput("ami", "AMI:",unique(dft$ami),selected=unique(dft$ami)),
    dateRangeInput("daterange", "Date range:",
                   start = min(as.Date(dft$date,"%m/%d/%Y")),
                   end   = max(as.Date(dft$date,"%m/%d/%Y")))

  ),

  mainPanel(

    plotOutput("topPlot"),
    plotOutput("bottomPlot")
  )
))
server.r
library(shiny)
p<-list()

     output$Plot <- renderPlot({
       p[input$plotSpot]<-trim_down(NA,input$type,input$form,input$class,input$ami,input$daterange)
       output$topPlot <- renderPlot(ifelse(input$position == "Top", print(p[1]), print(p[2])))
       output$bottomPlot <- renderPlot(ifelse(input$position == "Top", print(p[2]), print(p[1])))

 })
})

但是，这只制作了一张图表。我虽然切换保存 ggplot 的列表的索引，然后保持它们的绘制顺序相同，但没有运气。

4

1 回答 1

3

好的，我不打算处理所有这些代码，但这里有一个示例可以满足您的需求。如果我误解了，请尝试用一个最小的示例重新发布，这会将所有内容都剥离回您正在解决的问题。

用户界面

library(shiny)
shinyUI(pageWithSidebar(
  headerPanel("Plot position"),
  sidebarPanel(
    radioButtons("position", "Position", c("Top", "Bottom"))),
  mainPanel(
    plotOutput("topPlot"),
    plotOutput("bottomPlot"))))

服务器.R

library(shiny)
library(ggplot2)
dat <- data.frame(A = 1:10, B = rnorm(10))

shinyServer(function(input, output) {
  p1 <- ggplot(dat, aes(A, B)) + geom_point(colour = "red")
  p2 <- ggplot(dat, aes(A, B)) + geom_path(colour = "blue")
  output$topPlot <- renderPlot(ifelse(input$position == "Top", print(p1), print(p2)))
  output$bottomPlot <- renderPlot(ifelse(input$position == "Top", print(p2), print(p1)))
})

编辑

根据您对问题的新描述，以下可能会有所帮助。我认为你把它弄得太复杂了——如果不同地块的设置不同，那么每个不同的地块都有输入。可能只有一套，但会大大增加复杂性。

用户界面

library(shiny)
shinyUI(pageWithSidebar(
  headerPanel("Plot position"),
  sidebarPanel(
    h2("Top plot settings"),
    radioButtons("topPlotColour", "Colour:", 
                 list("Blue" = "blue",
                      "Red" = "red")),
    radioButtons("topPlotGeom", "Geom:", 
                 list("Point" = "point",
                      "Line" = "line")),
    h2("Bottom plot settings"),
    radioButtons("bottomPlotColour", "Colour:", 
                 list("Blue" = "blue",
                      "Red" = "red")),
    radioButtons("bottomPlotGeom", "Geom:", 
                 list("Point" = "point",
                      "Line" = "line"))),
  mainPanel(
    plotOutput("topPlot"),
    plotOutput("bottomPlot"))))

服务器.R

library(shiny)
library(ggplot2)
dat <- data.frame(A = 1:10, B = rnorm(10))

shinyServer(function(input, output) {
  p1_geom <-reactive({
    geom <- switch(input$topPlotGeom,
                   point = geom_point(colour = input$topPlotColour),
                   line = geom_line(colour = input$topPlotColour))
  })
  p2_geom <-reactive({
    geom <- switch(input$bottomPlotGeom,
                   point = geom_point(colour = input$bottomPlotColour),
                   line = geom_line(colour = input$bottomPlotColour))
  })
  p1_colour <- reactive({input$topPlotColour})
  output$topPlot <- renderPlot({print(ggplot(dat, aes(A, B), colour = p1_colour()) + p1_geom())})
  output$bottomPlot <- renderPlot(print(ggplot(dat, aes(A, B), colour = toString(quote(input$bottomPlotColour))) + p2_geom()))
})
于 2014-02-26T00:54:33.840 回答