我需要根据向量中的数字项创建一些滑块：
ui code：
library(shiny)
library(shinydashboard)
library(leaflet)
library(data.table)
library(ggplot2)
library(ggthemes)
library(usl)
ui<-dashboardPage(skin="green",
dashboardHeader(title = "ADM Logical Capacity Planning Service",titleWidth = 350),
dashboardSidebar(
sidebarMenu(
menuItem("Visualize & Create Model", tabName = "visualize",icon=icon("area-chart")),
menuItem("Forecast", tabName = "capacity", icon=icon("line-chart")) )
),
dashboardBody(
tags$head(tags$style(HTML('
.skin-blue .main-header .logo {
background-color: #3c8dbc;
}
.menuItem .main-header .logo:hover {
background-color: #3c8dbc;
}
'))),
tabItems(
tabItem("capacity",
fluidRow(
column(3,
wellPanel(
span("Given the growth rate, forecast the underlying dependent variable")
),
wellPanel(
# Create a uiOutput to hold the sliders
uiOutput("sliders")
),
# Generate a row with a sidebar
#sliderInput("capacity", "Growth Rate in Volume:", min=0, max=100, value=0,post="%"),
#br(),
#sliderInput("add_capacity", "Add Capacity in %:", min=0, max=100, value=0,post="%"),
br(),
wellPanel(
actionButton("calcbtn", "Calculate Forecast")
)
),
mainPanel(
h4("Prediction"),
verbatimTextOutput("forecast_summary"),
h4("Available Capacity"),
verbatimTextOutput("capacity_summary")
#h4("Peak Capacity"),
#verbatimTextOutput("peak_capacity")
)
)
),
tabItem("visualize",
pageWithSidebar(
headerPanel("Logical Capacity Planning Dashboard"),
sidebarPanel(
fileInput('file1', 'Upload CSV File to Create a Model',
accept=c('text/csv','text/comma-separated-values,text/plain','.csv')),
tags$hr(),
checkboxInput('header', 'Header', TRUE),
fluidRow(
column(6,checkboxGroupInput("xaxisGrp","X-Axis:", c("1"="1","2"="2"))),
column(6,radioButtons("yaxisGrp","Y-axis:", c("1"="1","2"="2")))
),
radioButtons('sep', 'Separator',
c(Comma=',', Semicolon=';',Tab='\t'), ','),
radioButtons('quote', 'Quote',
c(None='','Double Quote'='"','Single Quote'="'"),'"'),
uiOutput("choose_columns")
),
mainPanel(
tabsetPanel(
tabPanel("Data", tableOutput('contents')),
tabPanel("Create Model & Plot",plotOutput("plot"),verbatimTextOutput("PeakCapacity")),
tabPanel("Model Summary",verbatimTextOutput("summary"))
)
)
)
)
)
)
)
服务器代码：
server <- function(input, output, session)
{
###
output$sliders <- renderUI({
xv <- input$xaxisGrp
# First, create a list of sliders each with a different name
sliders <- lapply(1:length(xv), function(i) {
inputName <- xv[i]
sliderInput(inputName, inputName, min=0, max=100, value=0, post="%")
})
# Create a tagList of sliders (this is important)
do.call(tagList, sliders)
})
###
observeEvent(input$calcbtn, {
n <- isolate(input$calcbtn)
if (n == 0) return()
output$forecast_summary <- renderPrint({
n<-pred.model()
n<-data.frame(n)
row.names(n)<-NULL
print(n)
})
output$capacity_summary <- renderPrint({
n<-pred.model()
n<-data.frame(n)
row.names(n)<-NULL
#c<-round(peak.scalability(usl.model()),digits=0)
available<-round(((c-n[1,1])/c)*100,digits=0)
row.names(available)<-NULL
print(paste0(available,"%"))
})
# output$peak_capacity <- renderPrint({
# print(paste("Maximum Capacity: ", round(peak.scalability(pred.model()),digits=0)))
# })
output$plot_forecast <- renderPlot({
df <- data_set()
new_df<- pred.model()
print(sliders)
if (!is.null(df)){
xv <- input$xaxisGrp
yv <- input$yaxisGrp
print(xv)
print(yv)
if (!is.null(xv) & !is.null(yv)){
if (sum(xv %in% names(df))>0){ # supress error when changing files
df1<-data.frame(usl.model()$fitted)
colnames(df1)<-c("Model")
df<-cbind(df,df1)
Model=c("Model")
#ggplot(df, aes_string(xv,yv))+geom_point(size=3,colour="blue")+geom_line(data=df, aes_string(xv,Model),colour="orange",size=1)+
#geom_point(data=new_df,aes(new_df[,1],new_df[,2]), colour="red",size=10)+theme_bw()+theme(legend.position = "none")
#max_capacity<-round(peak.scalability(usl.model()),digits=0)
Ninety_Fifth_Perc<-quantile(df[,2], 0.95)
#peak<-round(peak.scalability(usl.model()),digits=0)
#available<-round(((max_capacity-Ninety_Fifth_Perc)/max_capacity)*100,digits=0)
new_d<-pred.model()
ggplot(df, aes_string(xv,yv))+geom_point(size=4,shape=21, fill="blue")+geom_line(data=df, aes_string(xv,Model),colour="orange",size=1)+
geom_point(data=new_df,aes(new_df[,1],new_df[,2]), colour="red",size=10)+
theme_bw()+theme(legend.position = "none")+geom_vline(xintercept=new_df[,1], colour="green",size=1.5)
}
}
}
})
})
###pred function
pred.model <- reactive({
xv <- input$xaxisGrp
yv <- input$yaxisGrp
#latest_df<-do.call(data.frame,setNames(lapply(xv,function(e) vector(typeof(e))),xv))
latest_df<-data.frame()
new_df1 = data.frame()
for(i in 1:length(xv)){
##xv[i]<-as.numeric(input$xv[i])
# capacity<-as.numeric(input$capacity)
#add_capacity<-as.numeric(input$add_capacity)
df <- data_set()
if (!is.null(df)){
if (!is.null(xv) & !is.null(yv)){
if (sum(xv[i] %in% names(df))>0){ # supress error when changing files
#usl.model <- usl(as.formula(paste(yv, '~', xv)), data = df)
#new_growth<-tail(df[,xv],1)*(1+capacity/100)
new_growth<-quantile(df[,xv[i]],0.95)*(1+input$xv[i]/100)
new_cap<-new_growth
new_df1[1,i] = setNames(data.frame(new_cap),xv[i])
row.names(new_df1)<-NULL
}
}
}
}
latest_df=new_df1
prediction<-predict(usl.model(),newdata = latest_df)
prediction<-data.frame(prediction)
prediction<-prediction[1,1]
return(prediction)
})
##end of pred function
###visualize section
dsnames <- c()
data_set <- reactive({
inFile <- input$file1
data(specsdm91)
if (is.null(inFile))
return(specsdm91)
data_set<-read.csv(inFile$datapath, header=input$header,
sep=input$sep, quote=input$quote,stringsAsFactors=F)
})
output$contents <- renderTable({data_set()})
observe({
dsnames <- names(data_set())
cb_options <- list()
cb_options[ dsnames] <- dsnames
updateCheckboxGroupInput(session, "xaxisGrp",
label = "X-Axis",
choices = cb_options,
selected = "")
updateRadioButtons(session, "yaxisGrp",
label = "Y-Axis",
choices = cb_options,
selected = "")
})
output$choose_dataset <- renderUI({
selectInput("dataset", "Data set", as.list(data_sets))
})
usl.model <- reactive({
df <- data_set()
if (!is.null(df)){
xv <- input$xaxisGrp
yv <- input$yaxisGrp
print(xv)
print(yv)
if (!is.null(xv) & !is.null(yv)){
if (sum(xv %in% names(df))>0){ # supress error when changing files
xv <- paste(xv, collapse="+")
lim <- lm(as.formula(paste(yv, '~', xv)), data = df)
return(lim)
}
}
}
})
##plot
output$plot = renderPlot({
df <- data_set()
if (!is.null(df)){
xv <- input$xaxisGrp
yv <- input$yaxisGrp
print(xv)
print(yv)
if (!is.null(xv) & !is.null(yv)){
if (sum(xv %in% names(df))>0){ # supress error when changing files
#plot(as.formula(paste(yv, '~', xv)), data = df, pch = 21)
#plot(usl.model(),add=TRUE)
df1<-data.frame(usl.model()$fitted)
colnames(df1)<-c("Best_Fit_Model")
#df<-cbind(df,df1)
Model<-c("Best_Fit_Model")
df1<-cbind(df[yv],df1)
#max_capacity<-round(peak.scalability(usl.model()),digits=0)
#Ninety_Fifth_Perc<-quantile(df[,2], 0.95)
#peak<-round(peak.scalability(usl.model()),digits=0)
#available<-round(((max_capacity-Ninety_Fifth_Perc)/max_capacity)*100,digits=0)
#new_d<-pred.model()
df.melt=melt(df, id=yv)
xx<-c("value")
ggplot(df.melt,aes_string(x = xx, y = yv)) + geom_point() +facet_wrap(~variable, scale="free")+theme_bw()+
geom_smooth(method="lm", se=F, colour="red")
# p2<-ggplot(df1,aes_string(x = yv, y = Model)) + geom_point() + theme_bw()+
# geom_smooth(method="lm", se=F, colour="red")
}
}
}
} )
##
output$summary <- renderPrint({
summary(usl.model())
})
output$choose_columns <- renderUI({
if(is.null(input$dataset))
return()
colnames <- names(contents)
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
}
答案 0 :(得分：2)
编辑：你也引用xaxisGrp作为输入（它不是）。这引起了一些问题。结果证明（见下面的例子）可以很好地解决问题。我没有意识到这一点！很酷的东西。
根据您的评论进行更新，您应该能够使用括号表示法访问每个输入。不过，您的问题仍然引用input$xaxisGrp但不存在。我也不确定你为什么要打电话给renderPlot({})，因为没有任何东西正在被绘制。
library(shiny)
ui <- shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
uiOutput("sliders")
),
mainPanel(
)
))
server <- shinyServer(function(input, output, session) {
xaxisGrp <- c("CPU", "Memory", "Disk")
output$sliders <- renderUI({
xv <- xaxisGrp
sliders <- lapply(1:length(xv), function(i) {
inputName <- xv[i]
sliderInput(inputName, inputName, min=0, max=100, value=0, post="%")
})
do.call(tagList, sliders)
})
output$plot_forecast <- renderPlot({
xv <- xaxisGrp
for(i in 1:length(xv)) {
value <- input[xv[i]]
}
})
})
我有点不确定你为什么用这种方式构建滑块。你看过namespacing了吗？或者甚至只写3个独立的输出？例如（您可以运行此命令以查看每个输入<key, value>对）：
library(shiny)
ui <- shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
uiOutput("slider1"),
uiOutput("slider2"),
uiOutput("slider3"),
uiOutput("sliders")
),
mainPanel(
verbatimTextOutput("inputVals")
)
)
))
server <- shinyServer(function(input, output, session) {
output$slider1 <- renderUI({
sliderInput("CPU2", "CPU2", min=0, max=100, value=0, post="%")
})
output$slider2 <- renderUI({
sliderInput("Memory2", "Memory2", min=0, max=100, value=0, post="%")
})
output$slider3 <- renderUI({
sliderInput("Disk2", "Disk2", min=0, max=100, value=0, post="%")
})
output$sliders <- renderUI({
xv <- c("CPU","Memory","Disk")
sliders <- lapply(1:length(xv), function(i) {
inputName <- xv[i]
sliderInput(inputName, inputName, min=0, max=100, value=0, post="%")
})
do.call(tagList, sliders)
})
output$inputVals <- renderPrint({
print(reactiveValuesToList(input))
})
})
# Run the application
shinyApp(ui = ui, server = server)
在您的情况下，看起来您的输入都是没有任何ID的呈现（xaxisGrp在您的示例中不是有效输入）。这很糟糕，他们每个人都需要一个独特的。命名空间是通过抽象UI生成函数并为每个输入保证唯一ID来解决此问题的一种方法。大多数时候不那么麻烦（除非，我不知道，你需要根据一些外部因素动态生成它们）只是创建多个单独的输入。
一旦正确构建输入，然后访问任何给定输入的值，只需在任何反应上下文中使用input$inputId语法：
output$CPUValue <- renderText({
input$CPU
})