Commit ba787829 authored by Aqeel Padaria's avatar Aqeel Padaria

add modal popup with accuracy, point selection and additional error metrics

parent b45f098c
......@@ -3,7 +3,7 @@ Title: Time Series Aggregator GUI
Version: 0.0.0.9000
Authors@R: person("Aqeel", "Padaria", email = "aqeel.padaria@gramener.com", role = c("aut", "cre"))
Description: GUI Frontend for the Time Series Aggregated Forecasting tool.
Depends: R (>= 3.3.2), openxlsx, shiny, DT, shinycssloaders, ggplot2, googleAuthR, shinyjs, ggseas, lubridate, tseries, urca
Depends: R (>= 3.3.2), openxlsx, shiny, DT, shinycssloaders, ggplot2, googleAuthR, shinyjs, ggseas, lubridate, tseries, urca, shinyBS
License:
Encoding: UTF-8
LazyData: true
......
......@@ -159,6 +159,8 @@ server = shinyServer(
toggle("googleauth-googleAuthUi", condition = authget)
shinyjs::enable("smalltable")
shinyjs::showElement("smalltable")
options(spinner.size=1)
......@@ -702,7 +704,7 @@ server = shinyServer(
totalvals <- rbind(original, newvals)
ggplot(totalvals, aes(valdate, value, group = 1)) +
g <- ggplot(totalvals, aes(valdate, value, group = 1)) +
geom_line(aes(colour = "Actuals")) +
geom_line(inherit.aes = FALSE, aes(valdate, fit, colour = "Fit/Forecast")) +
geom_line(inherit.aes = FALSE, aes(valdate, newval, colour = "Fit/Forecast")) +
......@@ -717,9 +719,11 @@ server = shinyServer(
breaks = c("80% Confidence", "95% Confidence"),
values = c(alpha("blue", 0.3), alpha("blue", 0.1)))
} else if(input$var=="All")
plot(1, axes=FALSE, xlab='', ylab='', pch='')
list(g, totalvals)
} else if(input$var=="All")
# plot(1, axes=FALSE, xlab='', ylab='', pch='')
ggplot(data.frame(1,1))
})
output$plot <- renderPlot({
......@@ -727,8 +731,36 @@ server = shinyServer(
#getNeed()
need(!is.null(user), 'Please register to continue')
)
getPlot()
getPlot()[[1]]
})
output$plot2 <- renderPlot({
validate(
#getNeed()
need(!is.null(user), 'Please register to continue')
)
getPlot()[[1]] + theme(legend.position = "top")
})
output$plotinfo <- renderText({
totalvals <- getPlot()[[2]]
breakpoint <- min(which(is.na(totalvals$value)))
futurePoint <- as.Date(input$plot_click$x, origin="1970-01-01")>=as.Date(totalvals$valdate[breakpoint])
totalvals$fakepoint <- 0
nearP <- nearPoints(totalvals, input$plot_click, "valdate", "fakepoint", threshold = 300)
paste0("Date = ", nearP$valdate[1], "\n", ifelse(futurePoint, "Forecast", "Fit"), " Value = ", ifelse(futurePoint, round(nearP$newval[1], 2), round(nearP$fit[1], 2)), ifelse(futurePoint, "", paste0("\nActual Value = ", round(nearP$value[1], 2))))
})
output$accuracyinfo <- renderText({
paste0("Bias: ", round(getAccuracy("bias"),2), "%\nRoot Mean Squared Error: ", round(getAccuracy("rmse"),2), "\nMean Absolute Error: ", round(getAccuracy("mae"), 2))
})
output$forecastTable <- renderTable({
......@@ -783,7 +815,7 @@ server = shinyServer(
newvals
}
}, include.rownames = TRUE, width = "70%")
}, include.rownames = TRUE, width = "60%")
output$smalltable <- renderTable({
......@@ -791,13 +823,95 @@ server = shinyServer(
#getNeed()
need(!is.null(user), 'Please authenticate to continue')
)
getsmalltable()
}, include.rownames = TRUE, width = "100%")
output$smalltable2 <- renderTable({
validate(
#getNeed()
need(!is.null(user), 'Please authenticate to continue')
)
getsmalltable()
}, include.rownames = TRUE, width = "100%")
getAccuracy <- function(acctype)
{
if(input$var!="All"){
modname <- dataSelect()
# original <- read.xlsx(datasetName, sheet = paste("d", modname, sep = "_"), colNames = TRUE, check.names = FALSE)
original <- getSheet(paste("d", modname, sep = "_"))
original$date <- as.Date(original$date, origin = "1899-12-30")
thisoriginal <- paste(input$metric, input$testsplit, input$var, sep = "-")
if(!sum(grepl(" ", names(original))))
{
thisoriginal <- gsub(" ", ".", thisoriginal)
}
original <- data.frame(valdate = original$date, value = original[,input$metric], fit = original[,thisoriginal])
origvals <- original$value
origfit <- original$fit
origvals <- origvals[!is.na(origfit)]
origfit <- origfit[!is.na(origfit)]
accval <- -1
if(acctype %in% "bias")
{
origvalbias <- c(origvals[-1], NA) - origvals
origfitbias <- c(origfit[-1], NA) - origfit
origvalbias <- origvalbias[!is.na(origvalbias)]
origfitbias <- origfitbias[!is.na(origfitbias)]
accval <- (origvalbias>0) == (origfitbias>0)
accval <- sum(accval)*100/length(accval)
accval <- 100 - accval
}
if(acctype %in% "rmse")
{
error <- origvals - origfit
accval <- sqrt(mean(error^2))
}
if(acctype %in% "mae")
{
error <- origvals - origfit
accval <- mean(abs(error))
}
accval
} else if(input$var=="All")
# plot(1, axes=FALSE, xlab='', ylab='', pch='')
0
}
getsmalltable <- function()
{
datasetName <- datasetSelect()
if(input$var!="All")
{
getV <- deselection()
# if(!is.null(input$reset) && input$reset!=0)
# {
# getV <- deselection()
# }
modname <- dataSelect()
......@@ -831,7 +945,7 @@ server = shinyServer(
data.frame()
}
}, include.rownames = TRUE, width = "100%")
}
output$table <- DT::renderDataTable({
......@@ -944,9 +1058,11 @@ server = shinyServer(
NULL
})
deselection <- eventReactive(input$reset,
deselection <- observeEvent(input$reset,
{
datasetName <- datasetSelect()
if(!is.null(input$reset) && input$reset!=0)
{
datasetName <- datasetSelect()
modname <- dataSelect()
timeval <- getTimeVal()
......@@ -977,10 +1093,11 @@ server = shinyServer(
models <- as.character(models)
models <- c("All",models)
updateSelectInput(session, "var", "Choose a model to display",
updateSelectInput(session, "var", "Choose a model to display",
choices = models,
selected = "All")
})
}
}, ignoreNULL = FALSE)
output$downloadData <- downloadHandler(
filename = function(){
......@@ -1207,24 +1324,44 @@ ui = #ui.R
tabPanel("Models", column(12,withSpinner(DT::dataTableOutput("table")),align="center"))
)
),
conditionalPanel(
condition = "input.var!='All'",
tabPanel("Plot",withSpinner(plotOutput("plot"))),
column(12,
fluidRow(splitLayout(cellWidths = c("80%","15%"),
tabPanel("Plot",withSpinner(plotOutput("plot"))),
actionButton("plotBut", label = "Expand"),
bsModal("modalExample", "Expanded Plot", "plotBut", size = "large",
plotOutput("plot2", click = "plot_click")
,
verbatimTextOutput("plotinfo"),
verbatimTextOutput("accuracyinfo"),
br(),
withSpinner(tableOutput("smalltable2"))
)
))
),
br(),
br(),
br(),
br(),
br(),
fluidRow(
br(),
column(12,
fluidRow(
#box(width=12, title="Check",
splitLayout(cellWidths = c("85%","15%","15%"),
splitLayout(cellWidths = c("80%","15%","15%"),
withSpinner(tableOutput("forecastTable")),
# withSpinner(actionButton("plotBut", label = "Expand")),
# actionButton("plotBut", label = "Expand"),
withSpinner(downloadButton("downloadData", label = "Download"))
)
#)
),
column(12,withSpinner(tableOutput("smalltable")),align="center")
)
)
# ,
# br(),
# column(12,withSpinner(tableOutput("smalltable")),align="center")
)
)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment