Scegliere in modo interattivo una posizione di trama in r con lucido

StackOverflow https://stackoverflow.com//questions/22004155

  •  20-12-2019
  •  | 
  •  

Domanda

Non sono davvero sicuro di come chiederlo, ma qui va:

Sto usando il pacchetto lucido in R. Attualmente sto emettendo una trama GGPlot2, che è solo bene.

Mi piacerebbe tracciare due grafici, uno sopra l'altro, confrontare visivamente le differenze tra loro.

Idealmente, mi piacerebbe essere in grado di selezionare la posizione di stampatura (parte superiore o inferiore) con un pulsante di opzione. Mentre modifico gli input per generare la trama che sto già ora ora, sembrerebbe in qualsiasi posizione è selezionata dai pulsanti di opzione superiore / inferiore. 

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

Grazie per l'aiuto ... Scusa per tanto codice, ma non sono sicuro di ciò che è sicuro omettere per la revisione di tutti. Se aiuta, sento che il problema potrebbe essere risolto affrontando GGPlot a tracciare su una griglia di layout ... Come, grid.arrange() che è guidato da un pulsante di opzione per la parte superiore o inferiore?

Basato su una risposta, ho provato questo: 

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

 })
})
.

Ma, questo rende solo un grafico. Pensando di cambiare gli indici dell'elenco che contiene il GGLOT e quindi mantenendo l'ordine in cui sono graffati, lo stesso farebbe il trucco, ma senza fortuna.

È stato utile?

Soluzione

OK, non avrei lavorato attraverso tutto quel codice, ma ecco un esempio che potrebbe fare ciò che vuoi.Se ho frainteso, prova a ripubblicare con un esempio minimal , che si spinge tutto il problema per il problema che stai affrontando.

ui.r 

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

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

.

Modifica

Secondo la tua nuova descrizione del problema, potrebbe aiutare quanto segue.Penso che tu stia rendendo troppo complicato - se le impostazioni saranno diverse per le diverse trame, hanno input per ciascuna delle diverse trame.Sarebbe possibile semplicemente avere un set, ma aumenterà drammaticamente la complessità.

ui.r 

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"))))
.

server.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()))
})
.
Autorizzato sotto: CC-BY-SA insieme a attribuzione
Non affiliato a StackOverflow
scroll top