Elegir interactivamente una ubicación de la parcela en R con brillante
https://stackoverflow.com//questions/22004155
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
RussianPregunta
No estoy realmente seguro de cómo preguntar esto, pero aquí va:
Estoy usando el paquete brillante en R. Actualmente estoy generando una parcela GGPLOT2, que está bien.
Me gustaría trazar dos gráficos, uno encima del otro, para comparar visualmente las diferencias entre ellos.
Idealmente, me gustaría poder seleccionar la posición de trazado (arriba o abajo) con un botón de radio. Mientras cambio las entradas para generar la trama que ya estoy recibiendo, aparecería en cualquier posición seleccionada por los botones de radio superior / inferior.
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))
})
})
Gracias por la ayuda ... Perdón por tanto código, pero no estoy seguro de lo que es seguro omitir para la revisión de todos. Si lo ayuda, siento que el problema se podría resolver al dirigirse a GGPLOT para trazar en algún diseño-rejilla ... como, grid.arrange() que está impulsado por un botón de radio para arriba o abajo?
Basado en una respuesta, he intentado esto:
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])))
})
})
Pero, eso solo hace un gráfico. A pesar de cambiar los índices de la lista que sostiene el GGPLOT y luego mantener el orden en el que se grafican lo mismo haría el truco, pero sin suerte.
Solución
OK, no iba a trabajar a través de todo ese código, pero aquí hay un ejemplo que puede hacer lo que quiere.Si he entendido mal, intente volver a publicar con un ejemplo de Minimal , que lo quita todo para simplemente el problema que está abordando.
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)))
})
editar
De acuerdo con su nueva descripción del problema, lo siguiente puede ayudar.Creo que lo está haciendo demasiado complicado: si las configuraciones serán diferentes para las diferentes parcelas, tienen entradas para cada una de las diferentes parcelas.Sería posible simplemente tener un conjunto, pero aumentaría la complejidad dramáticamente.
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()))
})
