Интерактивный выбор местоположения участка в R с Shiny
Я не совсем уверен, как спросить это, но здесь это идет:
Я использую блестящий пакет в 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, а затем поддержание порядка, в котором они представлены одинаково, сделало бы свое дело, но не повезло.
1 ответ
Хорошо, я не собирался прорабатывать весь этот код, но вот пример, который может делать то, что вы хотите. Если я неправильно понял, попробуйте сделать репост с минимальным примером, который сводит все назад к той проблеме, которую вы решаете.
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()))
})