I assume this is a duplicate question (sorry in advance), but I seem not able to resolve this issue. I created a shiny app, which implements a random forest model (party package) returning results with the caret package and visualizing a conditional interference tree with the ctree function. The app works fine locally. However, when I try the publish it no output gets displayed and I get the error "An error has occurred. Check your logs or contact the app author for clarification." What am I missing here?
The data I use for the model comes from a csv file stored on a dropbox account perhaps this might be the issue? I first used RData and switched to csv file, since this seems to be more often used with shiny.
I followed the steps described on: https://support.rstudio.com/hc/en-us/articles/229848967-Why-does-my-app-work-locally-but-not-on-shinyapps-io-, to see if this resoveld the issue. I restarted R and the computer. This did not work.
There is no code or data stored in the local environment when running locally.
All packages are loaded via library().
I load the data via a relative path df <- read.csv("data/df.csv"). All files are stored in a map called shinyapp as app.R and the df.csv in the file data.
The dataset is relatively large so I cannot display it here, but I created a dummy dataset which can be used to run the app.
library(shiny)
library(party)
library(caret)
#==============================================================================
#Use dummy dataset in stead of original data
#df <- read.csv("data/df.csv")
#df <- df[df$Taxon %in% names(table(df$Taxon))[table(df$Taxon) >= 50],]
#Create dummy dataset
df <- data.frame(Sample = 1:500, Taxon = paste0("spec", rbinom(n = 500, 2, 0.5)), SO4 = rnorm(500, 300, 50), pH = rnorm(500, 7, 1), NO3 = rnorm(500, 10, 3))
ui <- fluidPage(
titlePanel("Random Forest classification"),
sidebarPanel(
selectInput(inputId = "Spec", label = "Select species:", unique(df$Taxon)),
selectInput(inputId = "NAN", label = "Select how to use data:", c("All data (Also NAs)", "Complete data (No NAs)")),
numericInput(inputId = "SO4", label = "Choose value for SO4 (mg/l)", value = median(df$SO4, na.rm = T), min = 0, max = 15000),
numericInput(inputId = "pH", label = "Choose value for pH", value = median(df$pH, na.rm = T), min = 5, max = 10),
numericInput(inputId = "NO3", label = "Choose value for NO3 (mg/l)", value = median(df$NO3, na.rm = T), min = 0, max = 50),
h3("Validation parameters"),
textOutput("Validation"),
h3("Voting percentage"),
textOutput("Votingperc"),
h3("Remarks"),
h5("Note that every time the output of the model is different from
the previous. Samples with the absence of species are more
prevalent. Therefore, Every time the code is run, samples where a species
was present are the same. However, samples with absences are randomly
selected in equall amount and combines this with samples where the.
species was present Further, the random forest model randomly creates
trees by bootstrapping the dataset a 100 times. Each time a different
model is created. This model is a course estimation, since many more
important factors are absent. Validation of the model is performed by
training the model on 75% of the dataset and validating on the other 25%.
The predicting model is based on the total dataset. The Error:
replacement has 1 row, data has 0, occurs when the data for a species
has no measurements if complete data (without NAs) is used.")),
mainPanel(plotOutput("Imp"),
plotOutput("Tree")))
server <- function(input,output){
#Create model dataset
modpred <- reactive({
present <- df[df$Taxon == input$Spec,]
present$Spec <- 1
df1 <- df[!duplicated(df$Sample),]
df1 <- df1[!df1$Sample %in% present$Sample,]
if(input$NAN == "Complete data (No NAs)"){
present <- na.omit(present)
df1 <- na.omit(df1)}
if((nrow(df)-nrow(present)) > nrow(present)){
absent <- df1[sample(1:nrow(df1), nrow(present), replace = F),]}
else{
absent <- df1[sample(1:nrow(df1), nrow(present), replace = T),]}
absent$Spec <- 0
model.data <- rbind(present, absent)
model.data$Spec <- as.factor(model.data$Spec)
#Select 75% as training data
prestrain <- present[sample(1:nrow(present), floor(nrow(absent)*0.75), replace = F),]
abstrain <- absent[sample(1:nrow(absent), floor(nrow(present)*0.75), replace = F),]
train.data <- rbind(prestrain, abstrain)
train.data$Spec <- as.factor(train.data$Spec)
#Select the other 25% as validation data
val.data <- model.data[!rownames(model.data) %in% rownames(train.data),]
#Create nice conditional interference tree on all data
ct <- party::ctree(Spec~SO4+pH+NO3, data = model.data)
#Train and validate model
train.model <- party::cforest(Spec~SO4+pH+NO3, data=train.data, controls = party::cforest_classical(mtry = 1, ntree = 100))
validation.mod <- predict(train.model, newdata = val.data)
conf.mat.val <- table(val.data$Spec, predict(train.model, newdata = val.data))
val.results <- caret::confusionMatrix(conf.mat.val)
sumval <- paste0("AUC=", round(val.results$overall[1],2), " (LCI=", round(val.results$overall[3],2),"; ",
"HCI=", round(val.results$overall[4],2), "), ",
"Cohen's kappa=", round(val.results$overall[2],2), ", ",
"n-validation=", nrow(val.data), ", ", "n-training=", nrow(train.data), ", ", "n-total (model)=", nrow(model.data))
#Extract relative importance parameters
relimp <- as.data.frame(party::varimp(train.model))
relimp <- cbind.data.frame(rownames(relimp), relimp)
colnames(relimp)<-c("Parameter", "Relative importance")
rownames(relimp)<- NULL
relimp[,2] <- relimp$`Relative importance`/sum(relimp$`Relative importance`)*100
relimp <- relimp[order(-relimp$`Relative importance`),]
#Apply model on data input user interface
model <- party::cforest(Spec~SO4+pH+NO3, data=model.data, controls = party::cforest_classical(mtry = 1, ntree = 100))
pred.data <- setNames(data.frame(as.numeric(input$SO4), as.numeric(input$pH), as.numeric(input$NO3)), c("SO4", "pH", "NO3"))
pred <- predict(model, newdata = pred.data, type = "prob")
prob <- paste0("Voting percentage (Probability of presence) = ", round(pred$`1`[2]*100,0),"%", ",",
" Majority vote indicates = ", ifelse(pred$`1`[2] > 0.5, "Present", "Absent"))
combo <- list(Probability = prob, Validation = sumval, Tree = ct, Importance = relimp)})
output$Votingperc <- renderText({
combo <- modpred()
combo$Probability})
output$Validation <- renderText({
combo <- modpred()
combo$Validation})
output$Imp <- renderPlot({
combo <- modpred()
bar <- combo$Imp
barplot(bar$`Relative importance`,
names.arg = bar$Parameter, ylab = "Relative importance (%)")})
output$Tree <- renderPlot({
combo <- modpred()
plot(combo$Tree, inner_panel=node_inner(combo$Tree, pval = FALSE))})
}
shinyApp(ui,server)
Thank you in advance for your help.
Related
For this particular shiny example I am trying to apply a circular model and display and summarize it within the ggplot and a summary table. This is straightforward up until trying to add in reactive 'brushplot' capabilities. Each of the data points represent a date and the point of the selective graph is to be able to discard undesirable dates. As far as I've figured out, this requires the filtering and model fitting to be within a renderPlot which then leads to complications (unable to find the data/model) trying to call the filtered data and the circular model's statistical outputs outside the function and/or within another reactive function. This yields the Error: object 'k_circ.lm' not found So my questions are:
How can I read the filtered data from the renderPlot function
to the summarytable matrix?
How could I similarly add the fitted model values and residuals from k_circ.lm?
Is there a better or simpler way to arrange app to avoid this?
Alternatative code lines are commented out for a working (if poorly formatted) summary table.
library(dplyr) # For data manipulation
library(ggplot2) # For drawing plots
library(shiny) # For running the app
library(plotly) # For data manipulation
library(circular) # For Circular regressions
library(gridExtra)
# Define UI ----
ui <- fluidPage(
# App title ----
titlePanel("Circular Brushplot Demo"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
sidebarPanel(
actionButton("exclude_toggle", "Toggle points"),
actionButton("exclude_reset", "Reset")
),
# Main panel for displaying outputs ----
mainPanel(
#reactive plot output with point and 'brush' selection
fluidRow(plotOutput("k", height = 400,
click = "k_click",
brush = brushOpts(
id = "k_brush" ))),
plotOutput("s", height = 400)
)
)
)
# Define server logic
server <- function(input, output) {
psideg <- c(356,97,211,232,343,292,157,302,335,302,324,85,324,340,157,238,254,146,232,122,329)
thetadeg <- c(119,162,221,259,270,29,97,292,40,313,94,45,47,108,221,270,119,248,270,45,23)
## Data in radians then to "circular format"
psirad <- psideg*2*pi/360
thetarad <- thetadeg*2*pi/360
cpsirad <- circular(psirad)
cthetarad <- circular(thetarad)
cdat <- data.frame(cpsirad, cthetarad)
###### reactive brush plot ########
# For storing which rows have been excluded
vals <- reactiveValues(
keeprows = rep(TRUE, nrow(cdat)))
output$k <- renderPlot({
# Plot the kept and excluded points as two separate data sets
keep <- cdat[ vals$keeprows, , drop = FALSE]
exclude <- cdat[!vals$keeprows, , drop = FALSE]
## Fits circular model specifically for 'keeprows' of selected data
k_circlm <- lm.circular(type = "c-c", y = keep$cthetarad, x = keep$cpsirad, order = 1)
k_circlm
ggplot(keep, aes(cthetarad, cpsirad)) +
geom_point(aes(cthetarad, cpsirad, colour = keep$Vmag, size = 5))+
scale_colour_gradient(low ="blue", high = "red")+
geom_smooth(method = lm, fullrange = TRUE, color = "black") +
geom_point(data = exclude, shape = 13, size = 5, fill = NA, color = "black", alpha = 0.25) +
annotate("text", x = min(keep$cthetarad), y = Inf, hjust = .1, vjust = 1,
label = paste0("p value 1 = ", round(k_circlm$p.values[1], 2)), size = 7)+
annotate("text", x = min(keep$cthetarad), y = Inf, hjust = .1, vjust = 2.5,
label = paste0("p value 2 = ", round(k_circlm$p.values[2], 2)), size = 7)+
annotate("text", x = min(keep$cthetarad), y = Inf, hjust = .1, vjust = 4,
label = paste0("rho = ", round(k_circlm$rho, 2)), size = 7)+
xlab("Lighthouse Direction (radians)")+ ylab("ADCP site direction (radians)")+
theme(axis.title.x = element_text(size = 20), axis.title.y = element_text(size = 20))
})
# Toggle points that are clicked
observeEvent(input$k_click, {
res <- nearPoints(cdat, input$k_click, allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)})
# Toggle points that are brushed, when button is clicked
observeEvent(input$exclude_toggle, {
res <- brushedPoints(cdat, input$k_brush, allRows = TRUE)
vals$keeprows <- xor(vals$keeprows, res$selected_)})
# Reset all points
observeEvent(input$exclude_reset, {
vals$keeprows <- rep(TRUE, nrow(cdat))})
output$s <- renderPlot({
# Create Summary table
summarytable <- data.frame(matrix(ncol = 4, nrow = nrow(keep)))
colnames(summarytable) <- c( "Psi_dir", "Theta_dir", "Fitted_values", "Residuals")
# Un-comment lines below to read from non-reactive data for working summary table
#summarytable$Psi_dir <- round(cdat$cpsirad, 2)
#summarytable$Theta_dir <- round(cdat$cthetarad, 2)
# attempting to pull from circlm within render plot
# comment out for summarytable to work
summarytable$Psi_dir <- round(keep$cpsirad, 2)
summarytable$Theta_dir <- round(keep$cthetarad, 2)
summarytable$Fitted_values <- round(k_circ.lm$fitted)
summarytable$Residuals <- round(k_circ.lm$residuals)
# outputing table with minimal formatting
summarytable <-na.omit(summarytable)
t <- tableGrob(summarytable)
Q <- grid.arrange(t, nrow = 1)
Q
}
)
}
shinyApp(ui = ui, server = server)
Here's a few ideas - but there are multiple approaches to handling this, and you probably want to restructure your server function a bit more after working with this further.
First, you probably want a reactive expression that will update your model based on vals$keeprows as this changes with your clicks. Then, you can access the model results from this expression from both your plot and data table.
Here is an example:
fit_model <- reactive({
## Keep and exclude based on reactive value keeprows
keep = cdat[ vals$keeprows, , drop = FALSE]
exclude = cdat[!vals$keeprows, , drop = FALSE]
## Fits circular model specifically for 'keeprows' of selected data
k_circlm <- lm.circular(type = "c-c", y = keep$cthetarad, x = keep$cpsirad, order = 1)
## Returns list of items including what to keep, exclude, and model
list(k_circlm = k_circlm, keep = keep, exclude = exclude)
})
It will return a list that you can access from the plot:
output$k <- renderPlot({
exclude <- fit_model()[["exclude"]]
keep <- fit_model()[["keep"]]
k_circlm <- fit_model()[["k_circlm"]]
ggplot(keep, aes(cthetarad, cpsirad)) +
...
And can access the same from your table (though you have as renderPlot?):
output$s <- renderPlot({
keep = fit_model()[["keep"]]
k_circ.lm <- fit_model()[["k_circlm"]]
# Create Summary table
summarytable <- data.frame(matrix(ncol = 4, nrow = nrow(keep)))
...
Note that because the table length changes with rows kept, you might want to use nrow(keep) as I have above, rather than nrow(cdat), unless I am mistaken.
I also loaded gridExtra library for testing this.
I suspect there are a number of other improvements you could consider, but thought this might help you get to a functional state first.
This is my first attempt at using Shiny.
I have a simulated patient-level dataset with 4 variables:
group: Categorical, takes on values A, B and C. Represents 3 different treatment types that were used in the study.
week: Numeric variable, takes on values 1, 4, 8.Represents follow-up week.
painscore: Numeric variable, score on scale of 1-10, with 1 indicating no pain, 10 indicating extreme pain.
dependscore: Numeric variable, score on scale of 1-10, with 1 indicating no dependency on pain meds, 10 indicating extreme dependency.
Trying to build a simple app that accepts two inputs: the week, and the variable, and provides two outputs:
A boxplot of distribution of scores for the selected variable for the selected week. The x axis would represent the 3 levels of group (A, B and C).
A summary table the shows the number of observations, median, 25th percentile, 75th percentile and number of missing.
I was able to create the interactive boxplot, but I am unable to create the summary table. I was able to create static versions of this table in RMarkdown using the summaryBy function from doBy, but I am not able to implement it in Shiny. Tried following the advice here and here but I'm missing something.
Here's my code for reproducibility. Excuse the extensive annotations, (I'm a complete beginner) they are more for myself than for anyone else.
#libraries--------------------
library(shiny)
library(tidyverse)
library(knitr)
library(doBy)
#----------------------------
#input data
set.seed(123)
mydf <- data.frame( group = rep(rep(c("A","B","C"), each = 3), times = 3),
week = rep(rep(c(1,4,8), each = 9)),
painscore = sample(1:10, 27, replace = TRUE),
dependscore = sample(1:10, 27, replace = TRUE) )
#--------------------------
#define custom function to calculate summary statistics for column of interest.
#function explained in a little more detail when applied in the server function.
fun <- function(x) {
c( n = length(x),
m = median(x),
firstq = round(quantile(x)[2], 1),
lastq = round(quantile(x)[4], 1),
missing = mean(is.na(x)))
}
#-------------------------
#UI
ui <- fluidPage(
titlePanel("Shiny Boxplot and Table"),
#User can provide two different inputs
sidebarLayout(
sidebarPanel(
#1. allow user to pick week using radiobuttons
radioButtons(inputId = "pickedwk",
label = "week you want to display",
choices = c(1,4,8),
selected = 1),
#2. user can pick variable to visualize using dropdownboxes
selectInput(inputId = "var",
label = "variable to visualize",
list("How much pain did you feel today?" = "painscore",
"How dependent are you on medication?" = "dependscore")),
#helpertext
helpText("Enter week/variable choices here")
),
#Spaceholders for output
mainPanel(
plotOutput("boxplot"), #boxplot placeholder
htmlOutput("descriptives") #kable html table placeholder
)
)
)
#-------------------------
#Server
server <- function(input, output) {
#create dataset that subsets down to the week picked by user.
weeksub <- reactive({
mydf %>% filter(week == input$pickedwk[1])
})
#1. use reactive datasubset to render boxplot.
output$boxplot <- renderPlot({
ggplot(weeksub(), aes_string(x = "group", y = input$var)) + #input$var works here
geom_boxplot(fill = "red", outlier.shape = 15, outlier.color = "black") +
scale_y_continuous(name = as.character(input$var)) +
scale_x_discrete(name = "group") +
ggtitle(paste("Distribution of", as.character(input$var), "by treatment group"))
})
#2. use same reactive datasubset to render kable descriptive statistics for the variable picked.
output$descriptives <- renderText({
kable(summaryBy(input$var ~ group, data = as.data.frame(weeksub()), FUN = fun),
#note: here, I'm using the summaryBy function from package doBy. It takes the form var~ categoricalvar
# so, either painscore ~ group, or dependscore ~ group depending on what the user picked, and uses
#my custom function to return a table of count, median, 25th percentile, 75th percentile and missing count for
#the 3 levels of the group variable (for A, B, and C)
col.names = c("Number", "Median", "1Q", "3Q", "Missing"))
})
}#server function ends
# Run the application
shinyApp(ui = ui, server = server)
There are a couple of problems in your code:
The formula notation doesn't know how to deal with input$var. summaryBy supports an alternate syntax that works better. (You could also use as.formula and paste to build a formula.)
You are missing the "Group" column in col.names
You have to generate HTML from kable and pass it as HTML to the UI.
Change your table output to this:
output$descriptives <- renderUI({
HTML(kable(summaryBy(list(input$var, 'group'), data = as.data.frame(weeksub()), FUN = fun),
col.names = c('Group', "Number", "Median", "1Q", "3Q", "Missing"),
format='html'
))
})
I'm having trouble reading in .csv files dynamically based on ui input.
I have observations of precipitation and temperature data for different areas (ID'd here as zone). For a subset of those same areas, I also have frequency data of elevation observations. The app is meant as a CDF plotter of these three measurements for a region with many areas.
The problem is the elevation frequency data is much higher resolution than the precipitation and temperature data (together as p_t) and my code is too inefficient for good Shiny performance whenever users select elevation data (elev).
Instead of making one globally available filterable data.frame of all the data, I'm hoping to have Shiny go and grab individual .csvs of the frequency elevation data on the fly for just the area(s) that are selected in input$zone (via SelectizeInput). Once they're read in, uncount() so they're in observation format, then bundle together into one data.frame data() with any precipitation or temperature (observation) data that's selected, for ggplot's handy stat_ecdf() function with aesthetics set to data()$param and data()$zone.
Does this sound like an OK approach? If so, could you help me? In summary the main need is, if the parameter elev is selected, have Shiny find and read in those elevation .csvs whose file names match the areas selected. Thanks in advance for any help.
library(tidyverse)
library(shiny)
library(shinydashboard)
# generate sample observation data - precipitation and temperature
# not many megabytes so will just read in all at once at startup as one .csv
zone <- c(rep("abcde", 6), rep("fghij", 6), rep("klmno", 6),
rep("pqrst", 6))
set.seed(1)
val <- rnorm(24, 12, 18)
param <- rep(c("p", "t"), 12)
p_t <- data.frame(zone, val, param, stringsAsFactors = FALSE)
#head(p_t)
# zone val param
#1 abcde 0.7238314 p
#2 abcde 15.3055798 t
#3 abcde -3.0413150 p
#4 abcde 40.7150544 t
#5 abcde 17.9311399 p
#6 abcde -2.7684309 t
# generate sample elevation frequency data with many more observations -
# need to be stored as individual .csvs, too big to read in, uncount, and
# filter by input - too slow
# just want to bind and uncount as they're selected by user
setwd(./elevdata) # separate folder from which to pick out the elev data .csv in the main wd
# and prevent reading in of other app .csv data
val <- c(503, 506, 513, 689)
count <- c(32282, 53172, 45237, 34534)
data.frame(val, count) %>% mutate(zone = "abcde", param = "elev") %>%
write_csv("abcde.csv")
val <- c(-36, -39, -51, -98)
count <- c(52220, 5175, 299237, 100034)
data.frame(val, count) %>% mutate(zone = "fghij", param = "elev") %>%
write_csv("fghij.csv")
val <- c(2, 7, 13, 110)
count <- c(99222, 883172, 114237, 8347633)
data.frame(val, count) %>% mutate(zone = "klmno", param = "elev") %>%
write_csv("klmno.csv")
#only a subset of p_t zones have elev data - variable not currently used
#zoneswithelevdata <- list.files(pattern = "*.csv$")
#zoneswithelevdata <- gsub(".csv", "", zoneswithelevdata)
#shiny app using the above sample data
shinyApp(
ui = fluidPage(
sidebarLayout(sidebarPanel(
selectizeInput(
"zone", "zone", choices = unique(p_t$zone),
selected = c("a"),
multiple = TRUE),
checkboxGroupInput("param", "parameter",
choices = c("elev", "p", "t"), selected =c("elev", "p"))
),
mainPanel(
tabsetPanel(position=c("right"),
tabPanel(strong("static cdf"),
br(),
plotOutput("reg_plot", height = "750px")) )))
),
server = function(input, output) {
# elev_csv_counts_tobind <- reactive({
# if `elev` parameter is checked:
#* read_csv() of the csv(s) with csv file name %in% input$zone **
# * and bind together
#})
data <- reactive({
p_t_e <- p_t %>%
#first subset p_t by the zone(s) and param(s) selected
filter(param %in% input$param,
zone %in% input$zone) %>%
#now attach and uncount the elevation data
bind_rows({elev_csv_counts_tobind %>%
uncount(count)})
})
output$reg_plot <- renderPlot({
ggplot(data(), aes(val, color = param, linetype = zone)) +
labs(y = "proportion of total", x = NULL) +
stat_ecdf(pad = FALSE) + coord_flip()
})
}
)
Hey I am trying to build a shiny app for the purpose of calculating per cent chance of defaulting and I thought I fixed all my issues until I hit
Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)
but whenever I try to build something reactive I get
Error in RET#get_where(newdata = newdata, mincriterion = mincriterion) :
object 'loanfilev3' not found
I've looked over stackoverflow and tutorials and none seem to really help
Here is my UI and Server code for the first error, if someone could please highlight my issue that would be greatly appreciated.
UI:
library(shiny)
shinyUI(fluidPage(
titlePanel("Tabsets"),
# Sidebar layout with input and output definitions ----
sidebarLayout(
# Sidebar panel for inputs ----
sidebarPanel(
# Input: Select the random distribution type ----
numericInput("loan_amnt",
"Loan Amount:",
value = 5000,
min = 0,
max = NA),
numericInput("int_rate",
"Interest Rate:",
value = 10.5,
min = 0,
max = NA),
selectInput("term",
"Loan Term:",
c("36 months" = " 36 months",
"60 months" = " 60 months")),
numericInput("installment",
"Installment:",
value = 100,
min = 0,
max = NA),
textInput("grade", "Grade:", "B"),
textInput("emp_length", "Employment Length:", "5 years"),
numericInput("annual_inc",
"Annual Income:",
value = 40000,
min = 0,
max = NA),
numericInput("dti",
"Debt to Income Ratio:",
value = 5.4,
min = NA,
max = NA),
textInput("sub_grade", "SubGrade:", "B2"),
textInput("verification_status", "Verification Status:", "Verified"),
textInput("home_ownership", "Home Ownership:", "RENT"),
radioButtons("pymnt_plan", "Payment Plan:",
c("Yes" = "y",
"No" = "n"))
),
# Main panel for displaying outputs ----
mainPanel(
# Output: Tabset w/ plot, summary, and table ----
tabsetPanel(type = "tabs",
tabPanel("Decision Tree", verbatimTextOutput("ct")),
tabPanel("Generlized Linear Model", verbatimTextOutput("dl")),
tabPanel("K-Nearest Neighbour", verbatimTextOutput("kn"))
)
)
)
)
)
Server:
library(shiny)
library(pscl)
library(ROCR)
library(plyr)
library(dplyr)
library(ggplot2)
library(pROC)
library(caret)
library(e1071)
library(RMySQL)
library(reshape2)
USER <- 'inft216'
PASSWORD <- 'rosemary'
HOST <- 'bruce3.dc.bond.edu.au'
DBNAME <- 'inft216'
db <- dbConnect(MySQL(), user = USER, password = PASSWORD, host = HOST, dbname = DBNAME)
loanfile <- dbGetQuery(db, statement = "select * from lendingClub;")
dbDisconnect(db)
library(party)
colnames(loanfile) = tolower(colnames(loanfile))
bad_indicators = c("Charged Off",
"Default",
"Does not meet the credit policy. Status:Charged Off",
"Default Receiver",
"Late (16-30 days)",
"Late (31-120 days)")
loanfile$default = ifelse(loanfile$loan_status %in% bad_indicators, 1,
ifelse(loanfile$loan_status=="", NA, 0))
loanfile$loan_status = as.factor(loanfile$default)
loanfilev2 = dplyr::select(.data = loanfile,loan_status,loan_amnt,int_rate,term,installment,grade,emp_length,annual_inc,dti,sub_grade,verification_status,home_ownership,pymnt_plan)
loanfilev2$grade = as.factor(loanfilev2$grade)
loanfilev2$sub_grade <- as.factor(loanfilev2$sub_grade)
loanfilev2$term <- as.factor(loanfilev2$term)
loanfilev2$emp_length <- as.factor(loanfilev2$emp_length)
loanfilev2$verification_status <- as.factor(loanfilev2$verification_status)
loanfilev2$home_ownership <- as.factor(loanfilev2$home_ownership)
loanfilev2$pymnt_plan <- as.factor(loanfilev2$pymnt_plan)
loanfilev2$loan_status <- as.factor(loanfilev2$loan_status)
loanfilev2$grade <- as.numeric(loanfilev2$grade)
loanfilev2$sub_grade <- as.numeric(loanfilev2$sub_grade)
loanfilev2$term <- as.numeric(loanfilev2$term)
loanfilev2$emp_length <- as.numeric(loanfilev2$emp_length)
loanfilev2$verification_status <- as.numeric(loanfilev2$verification_status)
loanfilev2 <- loanfilev2[complete.cases(loanfilev2),]
set.seed(69)
train_index <- sample(seq_len(nrow(loanfilev2)), size = 5000)
TrainData<- loanfilev2[train_index, ]
ct = ctree(loan_status ~ ., data = TrainData)
dl <- glm(formula = loan_status ~ .,data = loanfilev2, family = binomial)
kn <- train(form = loan_status ~.,data = TrainData, method = 'knn')
shinyServer(function(input, output) {
loan_status <- c(0)
loan_amnt <- input$loan_amnt
int_rate <- input$int_rate
term <- input$term
installment <- input$installment
grade <- input$grade
emp_length <- input$emp_length
annual_inc <- input$annual_inc
dti <- input$dti
sub_grade <- input$sub_grade
verification_status <- input$verification_status
home_ownership <- input$home_ownership
pymnt_plan <- input$pymnt_plan
temp2 <- cbind(loan_status, loan_amnt, int_rate, term, installment, grade, emp_length, annual_inc, dti, sub_grade, verification_status, home_ownership, pymnt_plan)
loanfilev3 = dplyr::select(.data = loanfile,loan_status,loan_amnt,int_rate,term,installment,grade,emp_length,annual_inc,dti,sub_grade,verification_status,home_ownership,pymnt_plan)
loanfilev3 = rbind(loanfilev3, temp2, deparse.level = 0)
loanfilev3$grade = as.factor(loanfilev3$grade)
loanfilev3$sub_grade <- as.factor(loanfilev3$sub_grade)
loanfilev3$term <- as.factor(loanfilev3$term)
loanfilev3$emp_length <- as.factor(loanfilev3$emp_length)
loanfilev3$verification_status <- as.factor(loanfilev3$verification_status)
loanfilev3$home_ownership <- as.factor(loanfilev3$home_ownership)
loanfilev3$pymnt_plan <- as.factor(loanfilev3$pymnt_plan)
loanfilev3$loan_status <- as.factor(loanfilev3$loan_status)
loanfilev3$grade <- as.numeric(loanfilev3$grade)
loanfilev3$sub_grade <- as.numeric(loanfilev3$sub_grade)
loanfilev3$term <- as.numeric(loanfilev2$term)
loanfilev3$emp_length <- as.numeric(loanfilev3$emp_length)
loanfilev3$verification_status <- as.numeric(loanfilev3$verification_status)
loanfilev3 <- loanfilev3[complete.cases(loanfilev3),]
prediction1 = c(predict(object = ct, newdata = loanfilev3[886508], type = "prob"))
output$ct <- renderPrint({
as.data.frame(prediction1)[2,]*100
})
})
All input bindings (input$whatever) need to be used in reactive context for example: inside reactive() or observe or renderXXX etc. In your case you are doing stuff like loan_amnt <- input$loan_amnt outside of reactive context and that's what the error is about. See my update below. I have added your prediction model to an eventReactive that is triggered by some action button input$predict.
# add this button somewhere in your ui.R -
actionButton("predict", "Predict!")
update to server.R -
shinyServer(function(input, output) {
prediction <- eventReactive(input$predict, {
loan_status <- c(0)
loan_amnt <- input$loan_amnt
int_rate <- input$int_rate
term <- input$term
installment <- input$installment
grade <- input$grade
emp_length <- input$emp_length
annual_inc <- input$annual_inc
dti <- input$dti
sub_grade <- input$sub_grade
verification_status <- input$verification_status
home_ownership <- input$home_ownership
pymnt_plan <- input$pymnt_plan
temp2 <- cbind(loan_status, loan_amnt, int_rate, term, installment, grade, emp_length, annual_inc, dti, sub_grade, verification_status, home_ownership, pymnt_plan)
loanfilev3 = dplyr::select(.data = loanfile,loan_status,loan_amnt,int_rate,term,installment,grade,emp_length,annual_inc,dti,sub_grade,verification_status,home_ownership,pymnt_plan)
loanfilev3 = rbind(loanfilev3, temp2, deparse.level = 0)
loanfilev3$grade = as.factor(loanfilev3$grade)
loanfilev3$sub_grade <- as.factor(loanfilev3$sub_grade)
loanfilev3$term <- as.factor(loanfilev3$term)
loanfilev3$emp_length <- as.factor(loanfilev3$emp_length)
loanfilev3$verification_status <- as.factor(loanfilev3$verification_status)
loanfilev3$home_ownership <- as.factor(loanfilev3$home_ownership)
loanfilev3$pymnt_plan <- as.factor(loanfilev3$pymnt_plan)
loanfilev3$loan_status <- as.factor(loanfilev3$loan_status)
loanfilev3$grade <- as.numeric(loanfilev3$grade)
loanfilev3$sub_grade <- as.numeric(loanfilev3$sub_grade)
loanfilev3$term <- as.numeric(loanfilev2$term)
loanfilev3$emp_length <- as.numeric(loanfilev3$emp_length)
loanfilev3$verification_status <- as.numeric(loanfilev3$verification_status)
loanfilev3 <- loanfilev3[complete.cases(loanfilev3),]
predict(object = ct, newdata = loanfilev3[886508], type = "prob"))
})
output$ct <- renderPrint({
as.data.frame(prediction())[2,]*100
})
})
My form automatically updates the output before I press the Submit button. I read the description of "Submit" button and it says "Forms that include a submit button do not automatically update their outputs when inputs change, rather they wait until the user explicitly clicks the submit button". I am not sure if there's anything wrong.
For your information, here is my code. Data is from UCI (adult data)
Server.R
library(shiny)
library(caret)
predictSalary <- function(input){
adultData <- read.table("adult.data", header = FALSE, sep = ",", strip.white = TRUE)
adultName <- read.csv("adult.name.csv", header = FALSE, sep = ",", stringsAsFactors = FALSE)
names(adultData) <- adultName[, 1]
#Only select several attributes
selected <- c("age", "education", "marital.status", "relationship", "sex", "hours.per.week", "salary")
#selected <- c("age", "hours.per.week", "salary")
adultData <- subset(adultData, select = selected)
#The data is big, we only take 20% for the training
trainIndex = createDataPartition(adultData$salary, p=0.20, list=FALSE)
training = adultData[ trainIndex, ]
set.seed(33833)
modFit <- train(salary ~ ., method = "rpart", data=training)
predict(modFit, newdata = input)
}
shinyServer(
function(input, output) {
dataInput <- reactive({
age <- input$age
edu <- as.factor(input$edu)
marritalstat <- input$marritalstat
relationship <- input$relationship
sex <- input$sex
hours <- input$hours
data.frame(age = age,
education = edu,
marital.status = marritalstat,
relationship = relationship,
sex = sex,
hours.per.week = hours)
# age <- input$age
# hours <- input$hours
# data.frame(age = age, hours.per.week = hours)
})
# dat <- c(input$age, input$edu, input$marritalstat,
# input$relationship, input$sex, input$hours)
output$prediction <- renderPrint({predictSalary(dataInput())})
}
)
Ui.R
library(shiny)
shinyUI(
pageWithSidebar(
# Application title
headerPanel("Salary prediction"),
sidebarPanel(
numericInput('age', 'Age', 40, min = 17, max = 90, step = 1),
selectInput('edu', 'Education',
c("Bachelors"="Bachelors",
"Some-college"="Some-college",
"11th"="11th",
"HS-grad"="HS-grad",
"Prof-school"="Prof-school",
"Assoc-acdm"="Assoc-acdm",
"Assoc-voc"="Assoc-voc",
"9th"="9th",
"7th-8th"="7th-8th",
"12th"="12th",
"Masters"="Masters",
"1st-4th"="1st-4th",
"10th"="10th",
"Doctorate"="Doctorate",
"5th-6th"="5th-6th",
"Preschool"="Preschool")),
radioButtons('marritalstat', 'Marrital Status',
c("Married-civ-spouse" = "Married-civ-spouse",
"Divorced" = "Divorced",
"Never-married" = "Never-married",
"Separated" = "Separated",
"Widowed" = "Widowed",
"Married-spouse-absent" = "Married-spouse-absent",
"Married-AF-spouse" = "Married-AF-spouse")),
radioButtons('relationship', 'Relationship',
c("Wife" = "Wife",
"Own-child" = "Own-child",
"Husband" = "Husband",
"Not-in-family" = "Not-in-family",
"Other-relative" = "Other-relative",
"Unmarried" = "Unmarried")),
radioButtons('sex', 'Sex', c("Male", "Female")),
numericInput('hours', 'Hours per week', 40, min = 1, max = 99, step = 1),
submitButton('Submit')
),
mainPanel(
h3('Results of prediction'),
h4('The predicted salary is '),
verbatimTextOutput("prediction"),
h3('Prediction of salary'),
p('The application is designed to predict whether somebodys salary is greater or smaller than 50k.
The data is extracted from the adult data, provided by UCI database. In order to predict a salary, users need to
provide information of the person whom they would like to make prediction on. After filling in necessary information,
users will press "Submit". The information includes:'),
p(' - Age: must be from 17 to 90'),
p(' - Education'),
p(' - Marital status'),
p(' - Relationship'),
p(' - Gender'),
p(' - Total work hours per week: must be from 1 to 99')
)
)
)
I found the solution by using actionButton in replacement of submitButton. However, I think that there must be an ideal solution with using submitButton.