R Shiny problem with inputs belonging to a bsCollapsePanel - shiny

In this shiny App (code below), tabPanel 'Scatter plot', note that the plot is correctly rendered only when the user expand the bsCollapsePanel 'Marker settings' for the first time. Before expanding the panel 'Marker settings' at first time, the message Error: argument is of length zero is shown. Can someone find out where the error is in the code?
library(shiny)
library(shinyBS)
library(tidyverse)
shinyApp(
ui = fluidPage(
tabsetPanel(
tabPanel("mtcars",
dataTableOutput("mtcarsDATA")),
tabPanel("Scatter plot",
sidebarPanel(
bsCollapse(id = "Side panel", open = "Variables",
bsCollapsePanel("Variables",
uiOutput("varx"),
uiOutput("vary"))
)
),
mainPanel(
bsCollapsePanel("Marker settings",
uiOutput("showMrk"),
uiOutput("shpMrk"),
uiOutput("forPorForma"),
uiOutput("forPorVar"),
uiOutput("mrkTrsp")),
plotOutput('SctPlot'))
)
)
),
server <- function(input, output) {
output$mtcarsDATA <- renderDataTable({
data <- mtcars
getModel <- reactive({
names(data) })
output$varx <- renderUI({
selectInput("varsel.x", HTML("Select var X<span style='color: red'>*</span>"),
choices = as.list(getModel()), multiple = F) })
getModelnum <- reactive({
filterNumeric <- data[sapply(data, is.numeric)]
names(filterNumeric) })
output$vary <- renderUI({
selectInput("varsel.y", HTML("Select var Y<span style='color: red'>*</span>(numerical only)"),
choices = as.list(getModelnum()), multiple = F) })
output$showMrk <- renderUI({
checkboxInput("show_Mrk", "Show marker", value=T) })
output$shpMrk <- renderUI({
conditionalPanel(condition = "input.show_Mrk == T",
radioButtons("shp_Mrk", "Format marker",
choices = c("by shape", "by variable"))) })
output$forPorForma <- renderUI({
conditionalPanel(condition = "input.shp_Mrk == 'by shape' & input.show_Mrk == T",
sliderInput("for_PorForma", 'Deslize para mudar o formato do marcador',
min = 1, max=25, value = 16)) })
output$mrkTrsp <- renderUI({
conditionalPanel(condition = "input.show_Mrk == T",
sliderInput("mrk_Trsp", 'Slide to change marker transparency',
min = 0, max=1, value = .5, step=.05)) })
getModelcat <- reactive({
filterCaracter <- data[sapply(data, is.character)]
names(filterCaracter) })
output$forPorVar <- renderUI({
conditionalPanel(condition = "input.show_Mrk == 1 & input.shp_Mrk == 'by variable'",
selectInput("forPorVar.sel", "Select var",
choices = as.list(getModelcat()), multiple = F)) })
output$SctPlot <- renderPlot({
if(input$show_Mrk == T){
if(input$shp_Mrk == "by shape") {
geomPoint <- geom_point(alpha=1-input$mrk_Trsp, shape=input$for_PorForma) } else {
geomPoint <- geom_point(alpha=1-input$mrk_Trsp, aes_string(shape=(input$forPorVar.sel))) }} else {
geomPoint <- geom_point(alpha=0) }
p <- data %>%
ggplot(aes_string(x=input$varsel.x, y=input$varsel.y)) +
geomPoint
p
})
data
})
}
)

Related

Shiny actionbutton to set a customized default

In this shiny App (code below), I need that the button labeled 'Customized' returns:
Select var X: disp
Select var Y: drat
Point size: 1.0
This necessity is a bit similar to the reset button available on the R package 'shinyjs', with the diference of that the reset button returns to the code's default.
library(shiny)
library(shinyjs)
shinyApp(
ui <- fluidPage(
sidebarPanel(
fluidRow(
shinyjs::useShinyjs(),
id = "panel_vars",
# Buttons
uiOutput("varx"),
uiOutput("vary"),
numericInput("ptSize", "Point size",
min=.1, max=5, value = 2),
actionButton("p1", 'Reset variables XY'),
helpText(""),
actionButton("p2", 'Customized')
)
),
mainPanel(
plotOutput("plot")
)
),
server <- function(input, output) {
getModel <- reactive({
names(mtcars)
})
output$varx <- renderUI({
selectInput("varsel.x", "Select var X",
choices = as.list(getModel()), multiple = F)
})
output$vary <- renderUI({
selectInput("varsel.y", "Select var Y",
choices = as.list(getModel()), multiple = F)
})
observeEvent(input$p1, {
shinyjs::reset("panel_vars")
})
output$plot <- renderPlot({
p <- mtcars %>% ggplot(aes_string(x=input$varsel.x, y=input$varsel.y))+
geom_point(size=input$ptSize)
p
})
}
)
You can simply use updateSelectInput and updateNumericInput to do so:
library(shiny)
library(shinyjs)
library(dplyr)
library(ggplot2)
shinyApp(
ui <- fluidPage(
sidebarPanel(
fluidRow(
shinyjs::useShinyjs(),
id = "panel_vars",
# Buttons
uiOutput("varx"),
uiOutput("vary"),
numericInput("ptSize", "Point size",
min=.1, max=5, value = 2),
actionButton("p1", 'Reset variables XY'),
helpText(""),
actionButton("p2", 'Customized')
)
),
mainPanel(
plotOutput("plot")
)
),
server <- function(input, output,session) {
getModel <- reactive({
names(mtcars)
})
output$varx <- renderUI({
selectInput("varsel.x", "Select var X",
choices = as.list(getModel()), multiple = F)
})
output$vary <- renderUI({
selectInput("varsel.y", "Select var Y",
choices = as.list(getModel()), multiple = F)
})
observeEvent(input$p1, {
shinyjs::reset("panel_vars")
})
output$plot <- renderPlot({
req(input$varsel.x,input$varsel.y,input$ptSize)
p <- mtcars %>% ggplot(aes_string(x=input$varsel.x, y=input$varsel.y))+
geom_point(size=input$ptSize)
p
})
observeEvent(input$p2, {
updateSelectInput(session,'varsel.x',selected = 'disp')
updateSelectInput(session,'varsel.y',selected = 'drat')
updateNumericInput(session, "ptSize", value = 1.0)
})
}
)

How to visualise regression's predictions based on selected dataset and variables thereof

I have the following code that basically uploads the data and once you have clicked on the row of the dataset you have uploaded, it reads the file. If you go to the second page in the navbar called regression you can choose variables from the dataset and run linear model. That works with the summary table. I want to achieve is something like here: https://towardsdatascience.com/build-an-interactive-machine-learning-model-with-shiny-and-flexdashboard-6d76f59a37f9
I want the prediction table and plot visualisation based on what has been selected. Appreciate your understanding and helpfulness.
library(shiny)
library(magrittr)
library(shiny)
library(readxl)
library(tidyverse)
library(DT)
library(reactable)
ui <- navbarPage("Demo",
tabPanel("Data Manipulation",
sidebarLayout(
sidebarPanel(
fileInput("upload", "Upload your file", multiple = TRUE, accept = c(".csv", ".xlsx") ),
selectInput('mydropdown', label = 'Select', choices = 'No choices here yet'),
h2("Modify variable type"),
selectInput("var_name", "Select variable", choices = c()),
radioButtons("action", NULL,
choiceNames = c("Make factor", "Make numeric"),
choiceValues = c("factor", "numeric")),
actionButton("modify", "Do it!"),
verbatimTextOutput("str")
),
mainPanel(
DT::DTOutput("files"),
reactable::reactableOutput("uploaded_files")
)
)
),
tabPanel("Regression",
sidebarLayout(
sidebarPanel(
selectInput("dep_var", "Select dependent variable", choices = c()),
selectInput("ind_var", "Select independent variables", choices = c(), multiple = TRUE),
actionButton("submit_reg", "Do it!")),
mainPanel(
verbatimTextOutput(outputId = "regsum")
)
)
),
)
server <- function(input, output, session) {
output$files <- DT::renderDT({
DT::datatable(input$upload, selection = c("single"))
})
selected_file <- reactiveVal()
observe({
## when developing, use a sample file you have on your computer so that you
## can load it immediately instead of going through button clicks
# demofile <- "/path/to/your/file.csv"
# selected_file( read.csv(demofile) )
# return()
req(input$upload, input$files_rows_selected)
idx <- input$files_rows_selected
file_info <- input$upload[idx, ]
if (tools::file_ext(file_info$datapath) == "csv") {
selected_file(read.csv(file_info$datapath))
} else if (tools::file_ext(file_info$datapath) == "xlsx") {
selected_file(readxl::read_xlsx(file_info$datapath))
} else {
stop("Invalid file type")
}
})
output$uploaded_files <- reactable::renderReactable({
req(selected_file())
reactable::reactable(
selected_file(),
searchable = TRUE
)
})
observe({
req(input$upload)
file_names <- input$upload$name
updateSelectInput(
session,
"mydropdown",
choices = file_names
)
})
observe({
req(selected_file())
updateSelectInput(session, "var_name", choices = names(selected_file()))
})
output$str <- renderPrint({
req(selected_file())
str(selected_file())
})
observeEvent(input$modify, {
df <- selected_file()
if (input$action == "factor") {
df[[input$var_name]] <- as.factor(df[[input$var_name]])
} else if (input$action == "numeric") {
df[[input$var_name]] <- as.numeric(df[[input$var_name]])
} else {
stop("Invalid action")
}
selected_file(df)
})
# Second Page
observe({
req(selected_file())
Dependent <- updateSelectInput(session, "dep_var", choices = names(selected_file()))
})
observe({
req(selected_file())
Independent <- updateSelectInput(session, "ind_var", choices = names(selected_file()))
})
observeEvent(input$submit_reg, {
lm1 <- reactive({
req(selected_file())
Model1 <- lm(reformulate(input$ind_var, input$dep_var), data = selected_file())})
options(scipen=999)
output$regsum <- renderPrint({summary(lm1())})
DT::renderDataTable({
df <- req(selected_file())
DT::datatable(df %>% select(input$dep_var, input$ind_var) %>% mutate(predicted = predict(lm1()), residuals = residuals(lm1())) %>% select(input$dep_var, predicted, residuals),
rownames = FALSE, colnames = c('actual value', 'predicted value', 'residuals'), extensions = c('Buttons', 'Responsive'),
options = list(columnDefs = list(list(className = 'dt-center', targets = "_all")), dom = 'Blfrt',
buttons = c('copy', 'csv', 'excel', 'print'), searching = FALSE, lengthMenu = c(20, 100, 1000, nrow(housing)), scrollY = 300, scrollCollapse = TRUE))
})
})
}
shinyApp(ui, server)

Click function not working in shiny at once

This is the sample application where I have added click to automatically execute the action button
library(shiny)
library(shinyjs)
ui <- basicPage(
useShinyjs(),
fluidRow(
column(
width = 6,
textInput('a', 'Text A',"a1"),
textInput('b', 'Text B',"b1"),
# textInput('c', 'Text A',"c1"),
# textInput('d', 'Text B',"d1"),
# textInput('e', 'Text A',"e1"),
textInput('f', 'Text B',"f1"),
selectInput('gh', "select", choices = c(1,2,5,6,7), selected = 1),
actionButton("sub", "Submit"),
actionButton("ret", "auto click"),
uiOutput('f2'),
uiOutput('f3')
),
column(
width = 6,
tags$p(tags$span(id = "valueA", "")),
tags$script(
"$(document).on('shiny:inputchanged', function(event) {
if (event.name === 'a') {
$('#valueA').text(event.value);
}
});
"
)
,tableOutput('show_inputs')
)
)
)
server <- shinyServer(function(input, output, session){
# output$f2 <- renderUI({
# if(input$a == "a2"){
# textInput('ren', 'ren B',"ren z1")
# } else {
# NULL
# }
# })
AllInputs <- reactive({
x <- reactiveValuesToList(input)
})
asd <- reactiveValues()
observeEvent(input$sub,{
asd$df <- c(6,9)
output$f2 <- renderUI({
selectInput('f2', "select", choices = c(6,9), selected = asd$df)
})
output$f3 <- renderUI({
actionButton("new", "Generate iris table")
})
})
observeEvent(input$new, {
output$show_inputs <- renderTable({
head(iris)
})
})
observeEvent(input$ret,{
asd$df <- 9
sad <- data.frame(a = c("gh"), b = c(7))
updateSelectInput(session, inputId = sad$a, selected = sad$b)
click('sub')
updateSelectInput(session, inputId = "f2", selected = asd$df)
click('new') ### to generate IRIS table
# click('new')
})
})
shinyApp(ui = ui, server = server)
The process, when you click on "auto click", there is a button "Generate iris table" popping up and also this button should be get auto clicked so that iris table gets populated.
But here only "Generate iris table" button is popping up and no iris table getting displayed.
But if you click again on "auto click" button , we can see iris button
Expected output
The moment user clicks on "auto click", both "Generate iris table" button and iris table should be displayed
Nesting reactives causes issues.
Try this
server <- shinyServer(function(input, output, session){
# output$f2 <- renderUI({
# if(input$a == "a2"){
# textInput('ren', 'ren B',"ren z1")
# } else {
# NULL
# }
# })
AllInputs <- reactive({
x <- reactiveValuesToList(input)
})
asd <- reactiveValues(df=NULL)
observe({hide("f3")})
observeEvent(input$sub,{
asd$df <- c(6,9)
show("f3")
})
output$f3 <- renderUI({
actionButton("new", "Generate iris table")
})
output$f2 <- renderUI({
selectInput('f2', "select", choices = asd$df, selected = asd$df)
})
dt <- eventReactive(input$new, {head(iris)})
output$show_inputs <- renderTable({
dt()
})
observe({print(asd$df)})
observeEvent(input$ret,{
asd$df <- 9
sad <- data.frame(a = c("gh"), b = c(7))
updateSelectInput(session, inputId = sad$a, selected = sad$b)
click('sub')
updateSelectInput(session, inputId = "f2", selected = asd$df)
click('new') ### to generate IRIS table
# click('new')
})
})

Detecting arrow key (cursor key) in Shiny

I would like to link an action to the arrow/cursor keys in my Shiny app.
The action is already linked to pressing previous and next buttons. So I would like to add the eventExpr "cursor right" and "cursor left" to it, respectively. This is to plot one plot after another. Here is a simplified example with mtcars dataset.
datasets <- list(mtcars, iris, PlantGrowth)
ui <- fluidPage(
mainPanel(
titlePanel("Simplified example"),
tableOutput("cars"),
actionButton("prevBtn", icon = icon("arrow-left"), ""),
actionButton("nextBtn", icon = icon("arrow-right"), ""),
verbatimTextOutput("rows")
)
)
server <- function(input, output) {
output$cars <- renderTable({
head(dat())
})
dat <- reactive({
if (is.null(rv$nr)) {
d <- mtcars
}
else{
d <- datasets[[rv$nr]]
}
})
rv <- reactiveValues(nr = 1)
set_nr <- function(direction) {
rv$nr <- rv$nr + direction
}
observeEvent(input$nextBtn, { # here I would like add the sec. eventExpr.
set_nr(1)
})
observeEvent(input$prevBtn, { # here I would like add the sec. eventExpr.
set_nr(-1)
})
ro <- reactive({
nrow(dat())
})
output$rows <- renderPrint({
print(paste(as.character(ro()), "rows"))
})
vals <- reactiveValues(needThisForLater = reactive(30 * ro()))
}
shinyApp(ui = ui, server = server)```
You can attach a keydown event handler to the document:
datasets <- list(mtcars, iris, PlantGrowth)
js <- paste(
"$(document).on('keydown', function(event){",
" var key = event.which;",
" if(key === 37){",
" Shiny.setInputValue('arrowLeft', true, {priority: 'event'});",
" } else if(key === 39){",
" Shiny.setInputValue('arrowRight', true, {priority: 'event'});",
" }",
"});"
)
ui <- fluidPage(
tags$head(tags$script(HTML(js))),
mainPanel(
titlePanel("Simplified example"),
tableOutput("cars"),
actionButton("prevBtn", icon = icon("arrow-left"), ""),
actionButton("nextBtn", icon = icon("arrow-right"), ""),
verbatimTextOutput("rows")
)
)
server <- function(input, output) {
output$cars <- renderTable({
head(dat())
})
dat <- reactive({
if (is.null(rv$nr)) {
d <- mtcars
}
else{
d <- datasets[[rv$nr]]
}
})
rv <- reactiveValues(nr = 1)
set_nr <- function(direction) {
rv$nr <- rv$nr + direction
}
observeEvent(list(input$nextBtn, input$arrowRight), {
set_nr(1)
})
observeEvent(list(input$prevBtn, input$arrowLeft), {
set_nr(-1)
})
ro <- reactive({
nrow(dat())
})
output$rows <- renderPrint({
print(paste(as.character(ro()), "rows"))
})
vals <- reactiveValues(needThisForLater = reactive(30 * ro()))
}
shinyApp(ui = ui, server = server)

Input 2nd file in R Shiny only if results from 1st Input file satisfies requirement

I am relatively new on using R Shiny, I am trying to build Shiny app for predictive modeling.
I have R code ready with me and have loaded them in R Shiny.
Please refer to below ui.r and server.r which I have prepared.
shinyUI(
fluidPage(
titlePanel("Prediction"),
sidebarLayout(
sidebarPanel(
fileInput('file1', 'Choose Past CSV File',
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv')),
conditionalPanel(
condition = "output.fileUploaded",
fileInput('file2', 'Choose Future CSV File',
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv')),
downloadButton("downloadData", "Download Prediction")
)
),
mainPanel(
tabsetPanel(type = "tabs",
tabPanel('Results', (DT::dataTableOutput('table'))),
tabPanel("Model Summary",
verbatimTextOutput("summary"))
)
)
)
)
)
shinyServer(function(input, output) {
# hide the output
output$fileUploaded <- reactive({
return(!is.null(input$file1))
})
outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
data <- reactive({
File <- input$file1
if (is.null(File))
return(NULL)
complete <- read.csv(File$datapath,header=T,na.strings=c(""))
File1 <- input$file2
if (is.null(File1))
return(NULL)
raw.data <- read.csv(File1$datapath,header=T,na.strings=c(""))
#Change all variable to factor
complete[] <- lapply(complete, factor)
complete$Target <- recode(complete$Target," 'YES' = 1; 'Yes' = 1; 'NO' = 0 " )
set.seed(33)
splitIndex <- createDataPartition(complete$Target, p = .75, list = FALSE, times = 1)
trainData <- complete[ splitIndex,]
testData <- complete[-splitIndex,]
fitControl <- trainControl(method = "repeatedcv", number = 4, repeats = 4)
set.seed(33)
gbmFit1 <- train(as.factor(Target) ~ ., data = trainData, method = "gbm", trControl = fitControl,verbose = FALSE)
pred <- predict(gbmFit1, testData,type= "prob")[,2]
perf = prediction(pred, testData$Target)
pred1 = performance(perf, "tpr","fpr")
acc.perf <- performance(perf, "acc")
ind = which.max( slot(acc.perf, "y.values")[[1]])
acc = slot(acc.perf, "y.values")[[1]][ind]
output$summary <- renderPrint({
print(c(Accuracy=acc))
})
raw.data[] <- lapply(raw.data, factor)
testpred <- predict(gbmFit1, raw.data,type= "prob")[,2]
final = cbind(raw.data, testpred)
final
})
output$table = DT::renderDataTable({
final <- data()
DT::datatable(
data(), options = list(
pageLength = 5)
)
})
output$downloadData <- downloadHandler(
filename = function() { paste('SLA Prediction', '.csv', sep='') },
content = function(file) {
write.csv(data(),file)
}
)
return(output)
})
Model is created using first Input file, my requirement is user should asked to upload 2nd input file (for which they want to predict results) only if model Accuracy which calculated using first input file stored in variable acc should be more than 0.9, I am not able to get solution for this, can anyone help me in this.
Now the second file input depends on the variable acc and shows up only when it is bigger than 0.9. I additionally did some changes, mainly because your code didn't work on my laptop :). Instead of return(NULL) you can use the function req to ensure that the values are available.
library(shiny)
library(shinysky)
library(shinythemes)
library(caret)
library(gbm)
library(ROCR)
library(car)
ui <- shinyUI(
fluidPage(
theme = shinytheme("united"), # added new theme from the package 'shinythemes'
titlePanel("Prediction"),
sidebarLayout(
sidebarPanel(
fileInput('file1', 'Choose Past CSV File',
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv')),
uiOutput("dynamic")
),
mainPanel(
# added busyIndicator
busyIndicator(text = "Calculation in progress..",
img = "shinysky/busyIndicator/ajaxloaderq.gif", wait = 500),
tabsetPanel(type = "tabs",
tabPanel('Results',
(DT::dataTableOutput('table'))),
tabPanel("Model Summary",
verbatimTextOutput("summary")),
tabPanel("Predictions",
DT::dataTableOutput('tablePred'))
)
)
)
)
)
server <- shinyServer(function(input, output) {
# hide the output
output$fileUploaded <- reactive({
return(!is.null(input$file1))
})
outputOptions(output, 'fileUploaded', suspendWhenHidden=FALSE)
data <- reactive({
File <- input$file1
req(File)
complete <- read.csv(File$datapath,header=T,na.strings=c(""))
complete
})
model <- reactive({
complete <- lapply(data(), factor)
complete$Target <- recode(data()$Target," 'YES' = 1; 'Yes' = 1; 'NO' = 0 " )
set.seed(33)
splitIndex <- createDataPartition(data()$Target, p = .75, list = FALSE, times = 1)
trainData <- data()[ splitIndex,]
testData <- data()[-splitIndex,]
fitControl <- trainControl(method = "repeatedcv", number = 4, repeats = 4)
set.seed(33)
gbmFit1 <- train(as.factor(Target) ~ ., data = trainData, method = "gbm", trControl = fitControl,verbose = FALSE)
pred <- predict(gbmFit1, testData, type= "prob")[,2]
perf = prediction(pred, testData$Target)
pred1 = performance(perf, "tpr","fpr")
acc.perf <- performance(perf, "acc")
ind = which.max( slot(acc.perf, "y.values")[[1]])
acc = slot(acc.perf, "y.values")[[1]][ind]
retval <- list(model = gbmFit1, accuracy = acc)
return(retval)
})
output$summary <- renderPrint({
req(model())
print(model())
})
output$dynamic <- renderUI({
req(model())
if (model()$accuracy >= 0.9)
list(
fileInput('file2', 'Choose Future CSV File',
accept=c('text/csv',
'text/comma-separated-values,text/plain',
'.csv')),
downloadButton("downloadData", "Download Prediction")
)
})
data2 <- reactive({
req(input$file2)
File1 <- input$file2
raw.data <- read.csv(File1$datapath,header=T,na.strings=c(""))
raw.data
})
preds <- reactive({
raw.data <- data2()
testpred <- predict(model()$model, raw.data,type= "prob")[,2]
print(testpred)
final = cbind(raw.data, testpred)
final
})
output$table = DT::renderDataTable({
DT::datatable(data(), options = list(pageLength = 15))
})
output$tablePred = DT::renderDataTable({
req(input$file2)
DT::datatable(preds(), options = list(pageLength = 15))
})
output$downloadData <- downloadHandler(
filename = function() { paste('SLA Prediction', '.csv', sep='') },
content = function(file) {
write.csv(preds(),file)
}
)
return(output)
})
shinyApp(ui, server)