Related
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)
I have tried to use radio button as an argument in group_by. Since I'm new to Shiny with no JS script background so quite being blind in render/output. and how to adapt with normal R-code.
Please show me some useful document/example in applying input to normal R-code
(not as simple as what's shown in shiny- widget gallery)
dat <- read_csv("VN_MAT as of 202001.csv")
datasetInput <- reactive({
switch(input$radio3,
"A" = "PROD_MANUFACTURER, PROD_BRAND, MKT_SDESC",
"B" = "PROD_MANUFACTURER, PROD_LDESC, MKT_SDESC" )
})
dat_brand <- reactive({
dat %>%
data.frame() %>%
group_by(datasetInput()) %>%
summarise(PER_MAT.TY = round(sum(PER_MAT.TY),digit = 2), PER_MAT.YA = round(sum(PER_MAT.YA), digit
=2)) %>%
arrange(MKT_SDESC) %>%
data.frame() %>%
add_count(MKT_SDESC, wt = PER_MAT.TY) %>%
mutate("VALUE_SHARE_TY" = round(PER_MAT.TY/n, digit = 4)) %>%
select(-n) %>%
add_count(MKT_SDESC, wt = PER_MAT.YA) %>%
mutate("VALUE_SHARE_LY" = round(PER_MAT.YA/n, digit = 4)) %>%
select(-n) %>%
mutate("DIFF_SHARE_YA" = round(VALUE_SHARE_TY - VALUE_SHARE_LY, digit = 4)) %>%
mutate("VALUE_GROWTH" = round(PER_MAT.TY/PER_MAT.YA - 1, digit =4))
})
After trial & error, I can figure out the answer as following code
I have overcome it with using if + choice of code
server <- function(input, output, session){
library(shiny)
library(ggplot2)
library(tidyverse)
Principal <- c("a","a","a","a","b","b","b","b","c","c")
Value <- as.numeric(c(4,1,1,3,4,2,2,3,2,1))
g <- c("t1","t1","t1","t1","t1","t2","t2","t2","t2","t2")
b <- as.numeric(c(4,1,1,3,4,2,2,3,2,1))
df <- data.frame(Principal,Value,g,b)
output$plot <- renderPlot({
if(input$radio1 == 1){
df%>%
group_by(g,b) %>%
summarize(total = sum(Value)) %>%
ggplot(aes(x = total, y = b))+
geom_point()
}else{
df%>%
group_by(Principal,b) %>%
summarize(total = sum(Value)) %>%
ggplot(aes(x = total, y = b))+
geom_point()}
})
}
ui <- basicPage(
radioButtons(
inputId = "radio1",
label = "Radio1",
choices = c(1, 2)
),
plotOutput("plot")
)
shinyApp(ui = ui, server = server)
In the basic example below I would like to have all filters updated every time user add a filter.
ui :
library(shiny)
library(DT)
fluidPage(
fluidRow(
column(4,
DT::dataTableOutput("dt")
)
)
)
Server :
library(shiny)
shinyServer(function(input, output) {
df <- data.frame(var1 = c(rep("A",3),rep("B",3)), var2 = c("x","y","x","z","x","s"), var3 = c(1:6))
output$dt <- renderDataTable({
DT::datatable(df, filter = 'top')
})
})
When no filter applied :
When I apply filter on var1 to "A", s and z still remain in the suggested label in var2 filter even if there are no value to s or z
This is how I would do if I use selectInput for the filters. May not be the best solution, but it has always worked for me.
Code for ui.r
library(shiny)
library(DT)
fluidPage(
fluidRow(
column(4,selectizeInput("var1", label = "Var 1", choices = NULL, multiple = TRUE)),
column(4,selectizeInput("var2", label = "Var 2", choices = NULL, multiple = TRUE)),
column(4,selectizeInput("var3", label = "Var 3", choices = NULL, multiple = TRUE)),
column(4,DT::dataTableOutput("dt")
)
)
)
Code for server.R
library(shiny)
shinyServer(function(input, output, session) {
df <- data.frame(var1 = c(rep("A",3),rep("B",3)), var2 = c("x","y","x","z","x","s"), var3 = c(1:6))
updateSelectizeInput(session, 'var1', choices = sort(unique(df$var1)), server = TRUE)
updateSelectizeInput(session, 'var2', choices = sort(unique(df$var2)), server = TRUE)
updateSelectizeInput(session, 'var3', choices = sort(unique(df$var3)), server = TRUE)
filterData <- function(dataset){
df <- dataset
if (!is.null(input$var1)){
df <- df[which(df$var1 == input$var1),]
}
if (!is.null(input$var2)){
df <- df[which(df$var2 == input$var2),]
}
if (!is.null(input$var3)){
df <- df[which(df$var3 == input$var3),]
}
df
}
output$dt <- renderDataTable({
DT::datatable(filterData(df))
})
getwhich<-function(){
whichs<-which(df$var3 == df$var3)
if(!is.null(input$var1)){
whichs<-intersect(whichs,which(df$var1 %in% input$var1))
}
if(!is.null(input$var2)){
whichs<-intersect(whichs,which(df$var2 %in% input$var2))
}
if(!is.null(input$var3)){
whichs<-intersect(whichs,which(df$var3 %in% input$var3))
}
return(whichs)
}
observe({
w<-getwhich()
if(is.null(input$var1)){
updateSelectizeInput(session,"var1",choices=sort(unique(df$var1[w])))
}
})
observe({
w<-getwhich()
if(is.null(input$var2)){
updateSelectizeInput(session,"var2",choices=sort(unique(df$var2[w])))
}
})
observe({
w<-getwhich()
if(is.null(input$var3)){
updateSelectizeInput(session,"var3",choices=sort(unique(df$var3[w])))
}
})
})
Hope this helps.
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)
I just find a weird situation that add_tooltip displays wrong info when there are several ggvis plots with add_tooltip in one shiny app. Actually the order/item shown by add_tooltip in first ggvis is correct, but are wrong in the second or third ggvis plot. At the bottom is a simple version example with mtcars. Any suggestion?
Thanks a lot,
Ying
ui.R for add_tooltip_test
library(shiny)
library(ggvis)
shinyUI(fluidPage(
h5("add_tooltip test"),
sidebarLayout(
sidebarPanel(
checkboxInput(inputId="byVS", label="Selet vs value", value = FALSE),
conditionalPanel(
condition = "input.byVS == true",
selectizeInput(
inputId = "VS",
label = "Select a value",
multiple = FALSE,
choices = c(0,1),
selected=c(0)
)
),
checkboxInput(inputId="byAM", label="Selet am value", value = FALSE),
conditionalPanel(
condition = "input.byAM == true",
selectizeInput(
inputId = "AM",
label = "Select a value",
multiple = FALSE,
choices = c(0,1),
selected=c(0)
)
)
),
mainPanel(
uiOutput("plot1_ui"),
ggvisOutput("plot1")
)
)
))
server.R for add_tooltip_test
library(shiny)
library(ggvis)
library(dplyr)
shinyServer(function(input, output, session) {
vis <- reactive({
if(input$byVS == FALSE && input$byAM == FALSE){
myplotdata <- mutate(mtcars, carName=rownames(mtcars), id=1:nrow(mtcars))
my_values <- function(x) {
if(is.null(x)) return(NULL)
row <- myplotdata[myplotdata$id == x$id, ]
row$carName
}
myplotdata %>%
ggvis(x= ~hp, y= ~mpg) %>%
layer_points(key := ~id, fill = ~factor(cyl)) %>%
add_tooltip(my_values,"hover") %>%
group_by(cyl) %>%
layer_model_predictions(model = "lm", strokeDash = ~factor(cyl))
}else if(input$byVS == FALSE && input$byAM == TRUE){
amplotdata <- subset(mtcars, am == input$AM)
amplotdata <- mutate(amplotdata, carName=rownames(amplotdata), id=1:nrow(amplotdata))
am_values <- function(x) {
if(is.null(x)) return(NULL)
row <- amplotdata[amplotdata$id == x$id, ]
row$carName
}
amplotdata %>%
ggvis(x= ~hp, y= ~mpg) %>%
layer_points(key := ~id, fill = ~factor(cyl)) %>%
add_tooltip(am_values,"hover") %>%
group_by(cyl) %>%
layer_model_predictions(model = "lm", strokeDash = ~factor(cyl))
}else if(input$byVS == TRUE){
vsplotdata <- subset(mtcars, vs == input$VS)
vsplotdata <- mutate(vsplotdata, carName=rownames(vsplotdata), id=1:nrow(vsplotdata))
vs_values <- function(x) {
if(is.null(x)) return(NULL)
row <- vsplotdata[vsplotdata$id == x$id, ]
row$carName
}
vsplotdata %>%
ggvis(x= ~hp, y= ~mpg) %>%
layer_points(key := ~id, fill = ~factor(cyl)) %>%
add_tooltip(vs_values,"hover") %>%
group_by(cyl) %>%
layer_model_predictions(model = "lm", strokeDash = ~factor(cyl))
}
})
vis %>% bind_shiny("plot1", "plot1_ui")
})