반짝이는 플롯 위치를 대화식으로 선택합니다

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

  •  20-12-2019
  •  | 
  •  

문제

나는 이것을 어떻게 물어볼 지 확신하지 못해, 여기에 간다 :

R 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을 해결하기 위해 GGplot을 해결하여 문제가 해결 될 수 있습니다.

응답을 바탕으로 다음을 시도했습니다 : 

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을 보유하고있는 목록의 인덱스를 전환 한 다음 그래프로 표시된 순서를 유지하지만 운이지만 행운은 없습니다.

도움이 되었습니까?

해결책

OK, 저는 그 모든 코드를 통해 일하지 않을 것입니다. 그러나 여기서 원하는 것을 할 수있는 예입니다.오해 한 경우 최소한의 예제로 다시 게시하려고하면 해결 사항이있는 문제로 돌아갑니다.

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

편집

문제에 대한 새로운 설명에 따라 다음과 같은 도움이 될 수 있습니다.나는 그것이 너무 복잡해집니다 - 설정이 다른 플롯에 대해 다른 것으로되면 다른 플롯에 대한 입력이 있습니다.하나의 세트를 가질 수 있지만 복잡성을 극적으로 늘릴 수 있습니다.

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()))
})
.
라이센스 : CC-BY-SA ~와 함께 속성
제휴하지 않습니다 StackOverflow
scroll top