Related
I have created an R shiny app to produce k-means clustering results. The app is not producing results. However, it shows output in the console. Further, it also works fine when it knitted in Rmarkdown. If you have any opinion on the code part or any other suggestion to resolve this issue. Do let me know.
Here is my code.
library(shiny)
library(dplyr)
library(cluster)
ui <- pageWithSidebar(
headerPanel("Cluster Analysis"),
sidebarPanel(
fileInput('file1', 'Choose CSV File',
accept=c('text/csv','text/comma-separated-values,text/plain','.csv')),
tags$hr(),
checkboxInput('header', 'Header', TRUE),
helpText("You will be able to see the variable name after you add in a datafile"),
fluidRow(
column(6,checkboxGroupInput("variable","Select Variables:", c("1"="1","2"="2")))
),
sliderInput("kvalue", "Select number of clusters",
value = 3, min = 3, max= 6),
radioButtons('sep', 'Separator',
c(Comma=',', Semicolon=';',Tab='\t'), ','),
uiOutput("choose_columns")
),
mainPanel(
tabsetPanel(
tabPanel("Result", verbatimTextOutput("result")),
tabPanel("Data", tableOutput('contents'))
)
)
)
server <- function(input, output,session) {
dsnames <- c()
data_set <- reactive({
inFile <- input$file1
if (is.null(inFile))
return()
data_set <-read.csv(inFile$datapath, header=input$header,
sep=input$sep)
})
output$contents <- renderTable({data_set()})
observe({
dsnames <- names(data_set())
cb_options <- list()
cb_options[ dsnames] <- dsnames
updateCheckboxGroupInput(session, "variable",
label = "Select Variables",
choices = cb_options,
selected = "")
})
output$choose_dataset <- renderUI({
selectInput("dataset", "Data set", as.list(data_sets))
})
dfInput <- reactive({
data <- data_set()
if(is.null(data))
return()
data %>%
dplyr::select(input$variable)
}
)
output$result <- renderPrint(
{
dfin <- dfInput()
gp <- NULL
if (!is.null(dfin)){
df <- dfin
test <- na.omit(df)
test1 <- scale(test)
test2 <- daisy(test1)
seg.k <- kmeans(test2, centers=input$kvalue, nstart=25)
df$segment <- seg.k$cluster
test2 <- df%>%
dplyr::group_by(segment)%>%
dplyr::summarise_all(list(mean))
print(test2)
}
return(gp)
}
)
output$choose_columns <- renderUI({
if(is.null(input$dataset))
return()
colnames <- names(contents)
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
}
shinyApp(ui, server)
I have the following web application example:
library(shiny)
ui <- shinyUI(pageWithSidebar(
headerPanel("Add Features"),
sidebarPanel(width=4,
fluidRow(column(12,
h3('Features'),
uiOutput('uiOutpt')
)), # END fluidRow
fluidRow(
column(4,div()),
column(4,actionButton("add", "Add!")),
column(4,actionButton("remove", "Remove!")),
column(4,actionButton('goButton',"Analyze"))
) # END fluidRow
), # END sidebarPanel
mainPanel(
textOutput("text2"),
tableOutput('tbl')
)
))
server <- shinyServer(function(input, output) {
features <- reactiveValues(renderd=c(1),
conv=c(50),
inlabels=c('A'),
outlabels=c('B'))
df <- eventReactive(input$goButton, {
out <- lapply(features$renderd,function(i){
fv <- paste0('numInp_',i)
vn <- paste0('InLabel',i)
data.frame(Variable=input[[vn]], Value=input[[fv]] )
})
do.call(rbind,out)
})
output$nText <- renderText({
ntext()
})
output$text2 <- renderText({
paste(sprintf("You have selected feature: %s", paste(features$renderd,collapse=", ")))
})
output$tbl <- renderTable({
df()
})
# Increment reactive values array used to store how may rows we have rendered
observeEvent(input$add,{
out <- lapply(features$renderd,function(i){
fv <- paste0('numInp_',i)
vn <- paste0('InLabel',i)
vo <- paste0('OutLabel',i)
data.frame(inlabels=input[[vn]],outlabels=input[[vo]], conv=input[[fv]] )
})
df<-do.call(rbind,out)
print(df)
features$inlabels <- c(as.character(df$inlabels),' ')
features$outlabels <- c(as.character(df$outlabels),' ')
print(c(features$inlabels,features$outlabels))
features$renderd <- c(features$renderd, length(features$renderd)+1)
print(features$renderd)
print(names(features))
features$conv<-c(df$conv,51-length(features$renderd))
})
observeEvent(input$remove,{
features$renderd <- features$renderd[-length(features$renderd)]
})
# If reactive vector updated we render the UI again
observe({
output$uiOutpt <- renderUI({
# Create rows
rows <- lapply(features$renderd,function(i){
fluidRow(
# duplicate choices make selectize poop the bed, use unique():
column(4, selectizeInput(paste0('InLabel',i),
label = 'Input Name',selected=features$inlabels[i-1],
choices=unique(c(features$inlabels[i-1],features$outlabels[!features$outlabels %in% features$inlabels])),
options = list(create = TRUE))),
column(4, sliderInput(paste0('numInp_',i), label="Conversion",min = 0, max = 100, value = features$conv[i-1])),
column(4, selectizeInput(paste0('OutLabel',i),
label = "Output Name", selected=features$outlabels[i-1],
choices=unique(c(features$inlabels,features$outlabels)),
options = list(create = TRUE)))
)
})
do.call(shiny::tagList,rows)
})
})
})
shinyApp(ui=ui,server=server)
The problem is that each time, when we add a new fluidRow by clicking on the buton "add", the chosen values in the previous fluidRow are refreshed. I would like to change that. If I chose for instance, inputName='B', Conversion=50, outputName='A', I would like them to be constant even thought I have add or delete rows.
I have tried this but it didn't work:
library(shiny)
ui <- shinyUI(pageWithSidebar(
headerPanel("Add Features"),
sidebarPanel(width=4,
fluidRow(column(12,
h3('Features'),
uiOutput('uiOutpt')
)), # END fluidRow
fluidRow(
column(4,div()),
column(4,actionButton("add", "Add!")),
column(4,actionButton("remove", "Remove!")),
column(4,actionButton('goButton',"Analyze"))
) # END fluidRow
), # END sidebarPanel
mainPanel(
textOutput("text2"),
tableOutput('tbl')
)
))
server <- shinyServer(function(input, output) {
features <- reactiveValues(renderd=c(1),
conv=c(50),
inlabels=c('A'),
outlabels=c('B'))
df <- eventReactive(input$goButton, {
out <- lapply(features$renderd,function(i){
fv <- paste0('numInp_',i)
vn <- paste0('InLabel',i)
data.frame(Variable=input[[vn]], Value=input[[fv]] )
})
do.call(rbind,out)
})
output$nText <- renderText({
ntext()
})
output$text2 <- renderText({
paste(sprintf("You have selected feature: %s", paste(features$renderd,collapse=", ")))
})
output$tbl <- renderTable({
df()
})
# Increment reactive values array used to store how may rows we have rendered
observeEvent(input$add,{
out <- lapply(features$renderd,function(i){
fv <- paste0('numInp_',i)
vn <- paste0('InLabel',i)
vo <- paste0('OutLabel',i)
data.frame(inlabels=input[[vn]],outlabels=input[[vo]], conv=input[[fv]] )
})
df<-do.call(rbind,out)
print(df)
features$inlabels <- c(as.character(df$inlabels),' ')
features$outlabels <- c(as.character(df$outlabels),' ')
print(c(features$inlabels,features$outlabels))
features$renderd <- c(features$renderd, length(features$renderd)+1)
print(features$renderd)
print(names(features))
features$conv<-c(df$conv,51-length(features$renderd))
})
observeEvent(input$remove,{
features$renderd <- features$renderd[-length(features$renderd)]
})
# If reactive vector updated we render the UI again
observe({
output$uiOutpt <- renderUI({
# Create rows
rows <- lapply(features$renderd,function(i){
fluidRow(
# duplicate choices make selectize poop the bed, use unique():
column(4, selectizeInput(paste0('InLabel',i),
label = 'Input Name',selected=features$inlabels[i],
choices=c('A','B','C'),
options = list(create = TRUE))),
column(4, sliderInput(paste0('numInp_',i), label="Conversion",min = 0, max = 100, value = features$conv[i])),
column(4, selectizeInput(paste0('OutLabel',i),
label = "Output Name", selected=features$outlabels[i],
choices=c('A','B','C'),
options = list(create = TRUE)))
)
})
do.call(shiny::tagList,rows)
})
})
})
shinyApp(ui=ui,server=server)
I am sure that it's very easy to figure it out but I have no idea.
Thank you for your response.
I have found the answer of my question. I think that it could be useful for someone that's why I post the follwing example:
library(shiny)
ui <- shinyUI(
fluidPage(
actionButton("addFilter", "Add filter", icon=icon("plus", class=NULL, lib="font-awesome")),
uiOutput("filterPage1")
)
)
server <- function(input, output){
i <- 0
observeEvent(input$addFilter, {
i <<- i + 1
output[[paste("filterPage",i,sep="")]] = renderUI({
list(
fluidPage(
fluidRow(
column(6, selectInput(paste("filteringFactor",i,sep=""), "Choose factor to filter by:",
choices=c("factor A", "factor B", "factor C"), selected="factor B",
width="100%")),
column(6, actionButton(paste("removeFactor",i,sep=""), "",
icon=icon("times", class = NULL, lib = "font-awesome"),
onclick = paste0("Shiny.onInputChange('remove', ", i, ")")))
)
),
uiOutput(paste("filterPage",i + 1,sep=""))
)
})
})
observeEvent(input$remove, {
i <- input$remove
output[[paste("filterPage",i,sep="")]] <- renderUI({uiOutput(paste("filterPage",i + 1,sep=""))})
})
}
shinyApp(ui, server)
Have a nice day.
I need to create some sliders based on number items in a vector:
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 code:
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)
})
}
EDIT: You're also referencing xaxisGrp as an input (which it isn't). That's causing some issues. Turns out fixing that (see the example below) makes things work nicely. I didn't realize that! Cool stuff.
Updating based on your comment, you should be able to access each input using bracket notation. Your question is still referencing input$xaxisGrp which doesn't exist, though. I'm also not sure why you're calling renderPlot({}) since nothing's being plotted.
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]]
}
})
})
I'm a little unsure why you're constructing the sliders this way. Have you looked into namespacing? Or even just write 3 separate outputs? For example (you can run this to see each input <key, value> pair):
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)
In your case, it looks like your inputs are all rendering without any ID (xaxisGrp isn't a valid input in your example). That's bad, they each need a unique one. Namespacing is one way to solve for this by abstracting the UI-generating functions and guarantee unique IDs for each input. Less cumbersome most times (unless, I don't know, you need to dynamically generate them based on some external factor) is to just create multiple individual inputs.
Once you're building the inputs correctly, then to access any given input's value, just use the input$inputId syntax within any reactive context:
output$CPUValue <- renderText({
input$CPU
})
library(shiny)
library(shinydashboard)
library(leaflet)
library(data.table)
library(ggplot2)
library(usl)
ui <- pageWithSidebar(
headerPanel("CSV Viewer"),
sidebarPanel(
fileInput('file1', 'Choose CSV File',
accept=c('text/csv','text/comma-separated-values,text/plain','.csv')),
tags$hr(),
checkboxInput('header', 'Header', TRUE),
fluidRow(
column(6,radioButtons("xaxisGrp","X-Axis:", c("1"="1","2"="2"))),
column(6,checkboxGroupInput("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("Plot",plotOutput("plot")),
tabPanel("Summary",uiOutput("summary"))
)
)
)
####server
server <- function(input, output,session) {
dsnames <- c()
u<-
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)
})
output$contents <- renderTable({data_set()})
observe({
dsnames <- names(data_set())
cb_options <- list()
cb_options[ dsnames] <- dsnames
updateRadioButtons(session, "xaxisGrp",
label = "X-Axis",
choices = cb_options,
selected = "")
updateCheckboxGroupInput(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()
# print(df)
df2 <- df[,c(input$xaxisGrp, input$yaxisGrp)]
#gp <- NULL
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
usl.model <- usl(as.formula(paste(yv, '~', xv)), data = df)
return(usl.model())
}
}
}
#return(gp)
}
)
##plot
output$plot = renderPlot({
plot(usl.model())
} )
##
# output$summary <- renderUI({
# summary(usl.model())
#})
##
output$choose_columns <- renderUI({
if(is.null(input$dataset))
return()
colnames <- names(contents)
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
}
shinyApp(ui, server)
As you can see I have the df printed. Any ideas?
EDIT: Please give a reproducible example of your data. Without that, it's hard to imagine what the data types are. In general, I think you have potentially two problems:
What is gp? You need to return not gp but usl.model
Your renderUI is not passing a UI object (i.e. not something the output function will know what to do with).
Your problem is that usl.model is not actually being saved anywhere, because it's being called within renderPlot, which returns only the plot. Since you want usl.model to be consumed by two functions, you should take one of the following approaches.
Approach 1:
Define a reactive function for usl.model and reference it in your two output functions.
usl.model <- reactive({
# some calculations probably ending in
usl.model <- usl(as.formula(paste(yv, '~', xv)), data = df)
usl.model
})
This allows you to reference your model output as usl.model() (the parenthesis are important!), e.g.
output$plot <- renderPlot( plot(usl.model(), add=TRUE) )
Approach 2
Create a reactiveValues() variable to store your usl.model as calculated in the plot function.
usl.model <- reactiveValues(data = NULL)
output$plot = renderPlot({
# some calculations probably ending in
usl.model$data <- usl(as.formula(paste(yv, '~', xv)), data = df)
})
You can then refer to your model output anywhere as usl.model$data
Approach two is possibly worse because it requires the plot function to be run first.
I hope you can help me again as I stumbled over another problem in Shiny:
I would like a graphic to change in the moment it is clicked on. Here's a minimal example:
ui.R (shows a clickable graphic and a text frame)
shinyUI(fluidPage(
titlePanel("Title"),
sidebarLayout(
sidebarPanel(
),
mainPanel(
plotOutput("graph", width = "100%", click = "plot_click"),
verbatimTextOutput("click_info")
)
)
)
)
server.R (graphic just contains "A","B","C","D", on click I get the nearest letter in the text frame)
shinyServer(function(input, output, session) {
# Visualization output:
observe({
output$graph <- renderPlot({
data <- data.frame(x=c(1,2,1,2), y=c(1,1,2,2),
values=c("A","B","C","D"), stringsAsFactors=FALSE)
plot(data$x, data$y, pch=data$values)
})
})
# interaction click in graph
observe({
click <- c(input$plot_click$x, input$plot_click$y)
data <- data.frame(x=c(1,2,1,2), y=c(1,1,2,2),
values=c("A","B","C","D"), stringsAsFactors=FALSE)
nearest_point <- which.min(apply(data[,1:2], 1, function(a) sum(((click-a)^2))))
id <- data$values[nearest_point]
output$click_info <- renderPrint({
id
})
})
})
Now what I want is to mark the letter I clicked on in the graph, for example by another color. But all my tries failed so far.
Try this:
ui <- shinyUI(fluidPage(
titlePanel("Title"),
sidebarLayout(
sidebarPanel(
),
mainPanel(
plotOutput("graph", width = "100%", click = "plot_click"),
verbatimTextOutput("click_info")
)
)
)
)
server <- shinyServer(function(input, output, session) {
data <- data.frame(x=c(1,2,1,2), y=c(1,1,2,2),
values=c("A","B","C","D"), stringsAsFactors=FALSE)
# Visualization output:
observe({
output$graph <- renderPlot({
plot(data$x, data$y, pch=data$values)
})
})
# interaction click in graph
observe({
if(is.null(input$plot_click$x)) return(NULL)
click <- c(input$plot_click$x, input$plot_click$y)
print(click)
nearest_point <- which.min(apply(data[,1:2], 1, function(a) sum(((click-a)^2))))
id <- data$values[nearest_point]
output$click_info <- renderPrint({
id
})
color <- rep("black",length(data$x))
color[data$values==id] <- "red"
isolate({
output$graph <- renderPlot({
plot(data$x, data$y, pch=data$values, col=color)
})
})
})
})
shinyApp(ui=ui,server=server)
With ggplot2
Edited as per #bunks suggestions:
library(ggplot2)
library(shiny)
ui <- shinyUI(fluidPage(
titlePanel("Title"),
sidebarLayout(
sidebarPanel(
),
mainPanel(
plotOutput("graph", width = "100%", click = "plot_click"),
verbatimTextOutput("click_info")
)
)
))
server <- shinyServer(function(input, output, session) {
data <- data.frame(x=c(1,2,1,2),
y=c(1,1,2,2),
values=c("A","B","C","D"),
stringsAsFactors=FALSE,
color=rep("1",4))
makeReactiveBinding('data')
output$graph <- renderPlot({
ggplot(data=data,aes(x=x,y=y,label=values,color=color))+geom_text()+theme_classic()+guides(colour=FALSE)
})
observeEvent(input$plot_click, {
# Get 1 datapoint within 15 pixels of click, see ?nearPoints
np <- nearPoints(data, input$plot_click, maxpoints=1 , threshold = 15)
output$click_info <- renderPrint({np$values})
data$color <<- rep("1",length(data$x))
data$color[data$values==np$values] <<- "2"
})
})
shinyApp(ui=ui,server=server)