In antononcube/QRMon-R: Quantile Regression Monad

library(flexdashboard)
library(magrittr)
library(ggplot2)
library(QRMon)
library(OutlierIdentifiers)

Sidebar {.sidebar}

selectInput( inputId = "dataSpec", label = "Data:", choices = c( "DistributionData", "FinancialData", "TemperatureData" ), selected = "DistributionData" )

checkboxInput( inputId = "dateAxisQ", label = "Date axis:", value = FALSE )

checkboxInput( inputId = "joinedPlotQ", label = "Joined plot:", value = FALSE )

hr()

textInput( inputId = "probs", label = "Probabilities:", value = "0.1, 0.5, 0.9")

sliderInput( inputId = "df", label = "Degrees of freedom:", min = 1, max = 120, step = 1, value = 12 )

hr()

checkboxInput( inputId = "relativeErrorsQ", label = "Use relative errors:", value = FALSE )

numericInput( inputId = "outlierThreshold", label = "Outliers threshold:", min = 0, max = 100, step = 0.05, value = 1 )

selectInput( inputId = "outlierIdentifier", 
             label = "Outlier identifier:", 
             choices = c( "Hampel", "SPLUSQuartile", "Quartile"), 
             selected = "Hampel" )

Data and fit

lsGroupColors <- c( "Data" = "gray60", 
                    "VarianceDiff" = "gray60", 
                    "Outliers" = "red", 
                    "VarianceOutliers" = "red", 
                    "Anomalies" = "red" )

dataset <- reactive({
  res <- list( "DistributionData" = dfDistributionData, "FinancialData" = dfFinancialData, "TemperatureData" = dfTemperatureData )[[input$dataSpec]]
  QRMonUnit( setNames( res,  c("Regressor", "Value") ) ) %>% QRMonTakeData
})

outlierIdentifierParameters <- reactive({
  list( 
    "Hampel" = HampelIdentifierParameters, 
    "SPLUSQuartile" = SPLUSQuartileIdentifierParameters, 
    "Quartile" = QuartileIdentifierParameters
  )[[input$outlierIdentifier]]
})  

pointOutlierIdentifier <- reactive({
  function(x) TopOutlierIdentifier(data = x, identifier = outlierIdentifierParameters()) 
})

varianceOutlierIdentifier <- reactive({
  function(x) OutlierIdentifier(data = x, identifier = outlierIdentifierParameters()) 
})

lsProbs <- reactive({
  res <- strsplit( input$probs, ",|\\s")[[1]]
  as.numeric( res[nchar(res) > 0 ] )
})

qrObj <- reactive({

  QRMonUnit( dataset() ) %>%
  QRMonQuantileRegression( df = input$df, probabilities = lsProbs() )
})

Summary

renderPrint({
  cat( paste0("Number of points: ", nrow(dataset()), "\n"));
  summary(qrObj() %>% QRMonTakeData)
})

Data and regression quantiles

plotQR <- reactive({
  qrObj() %>% 
    QRMonPlot( echoQ = FALSE, 
               datePlotQ = input$dateAxisQ, 
               dateOrigin = "1900-01-01", 
               dataPointsColor = if( input$joinedPlotQ ) { NULL } else { "gray60" },
               dataLineColor = if( input$joinedPlotQ ) { "gray60" } else { NULL } ) %>% 
    QRMonTakeValue
})

renderPlot( expr = {
  print(plotQR())
})

Errors

renderPlot( expr = {
  print(qrObj() %>% QRMonErrorsPlot(relativeErrorsQ = input$relativeErrorsQ, datePlotQ = input$dateAxisQ, dateOrigin = "1900-01-01" ))
})

Point anomalies

Outliers by regression quantiles

renderPlot( expr = {

  p <- 
    qrObj() %>% 
    QRMonOutliers %>% 
    QRMonOutliersPlot( 
      echoQ = FALSE, 
      plotRegressionCurvesQ = TRUE, 
      datePlotQ = input$dateAxisQ, 
      dateOrigin = "1900-01-01",
      dataPointsColor = if( input$joinedPlotQ ) { NULL } else { "gray60" },
      dataLineColor = if( input$joinedPlotQ ) { "gray60" } else { NULL } ) %>% 
    QRMonTakeValue

  print(p)

})

Anomalies by residuals using threshold

dfPointOutliers <- reactive({
  qrObj() %>% 
    QRMonFindAnomaliesByResiduals( threshold = input$outlierThreshold, outlierIdentifier = NULL, relativeErrorsQ = input$relativeErrorsQ ) %>% 
    QRMonTakeValue
})

renderPlot( expr = {

  if( is.null(dfPointOutliers()) || nrow(dfPointOutliers()) == 0 ) {
    dfPlotData <- cbind( Type = "Data", dataset() )
  } else {
    dfPlotData <- rbind( cbind( Type = "Data", dataset() ), 
                         cbind( Type = "Outliers", dfPointOutliers() ) )
  }

  ggplot( dfPlotData ) + 
    geom_point( aes( x = if(input$dateAxisQ) { as.POSIXct(Regressor, origin = "1900-01-01") } else { Regressor }, 
                     y = Value, 
                     color = Type ) ) +
    scale_colour_manual( values = lsGroupColors ) +
    xlab("Regressor")

})

Anomalies by residuals using outlier identifier

dfPointOutliersByFunc <- reactive({
  qrObj() %>% 
    QRMonFindAnomaliesByResiduals( threshold = NULL, outlierIdentifier = pointOutlierIdentifier(), relativeErrorsQ = input$relativeErrorsQ ) %>% 
    QRMonTakeValue
})

renderPlot( expr = {

  if( is.null(dfPointOutliers()) || nrow(dfPointOutliersByFunc()) == 0 ) {
    dfPlotData <- cbind( Type = "Data", dataset() )
  } else {
    dfPlotData <- rbind( cbind( Type = "Data", dataset() ), 
                         cbind( Type = "Outliers", dfPointOutliersByFunc() ) )
  }

  ggplot( dfPlotData ) + 
    geom_point( aes( x = if(input$dateAxisQ) { as.POSIXct(Regressor, origin = "1900-01-01") } else { Regressor }, 
                     y = Value, 
                     color = Type ) ) +
    scale_colour_manual( values = lsGroupColors ) +
    xlab("Regressor")

})

Variance anomalies

Regression quantiles for variance evaluation

renderPlot( expr = {

  print(
    QRMonUnit( qrObj() %>% QRMonTakeData ) %>% 
      QRMonQuantileRegression( df = input$df, probabilities = c( min(lsProbs()), max(lsProbs()) ) ) %>% 
      QRMonPlot( echoQ = FALSE, 
                 datePlotQ = input$dateAxisQ, 
                 dateOrigin = "1900-01-01",
                 dataPointsColor = if( input$joinedPlotQ ) { NULL } else { "gray60" },
                 dataLineColor = if( input$joinedPlotQ ) { "gray60" } else { NULL } ) %>% 
      QRMonTakeValue 
  )

})

Conditional variance

renderPlot( expr = {

  lsRes <- qrObj() %>% QRMonPredict( ) %>% QRMonTakeValue
  dfRes <- dplyr::bind_rows( lsRes, .id = "Prob")

  maxPPos <- which.max( as.numeric(names(lsRes)) )
  minPPos <- which.min( as.numeric(names(lsRes)) )

  dfDiffs <- data.frame( Regressor = lsRes[[maxPPos]]["Regressor"], Value = abs(lsRes[[maxPPos]]["Value"] - lsRes[[minPPos]]["Value"] ) )

  lsOutlierPos <- varianceOutlierIdentifier()( dfDiffs$Value )

  if(length(lsOutlierPos) == 0 || sum(lsOutlierPos) == 0 ) {
    dfPlotData <- cbind( Type = "Data", dfDiffs )
  } else {
    dfPlotData <-  rbind( cbind( Type = "VarianceDiff", dfDiffs ), 
                          cbind( Type = "Outliers", dfDiffs[lsOutlierPos, ,drop=F] ) )
  }

  ggplot( dfPlotData ) + 
    geom_point( aes( x = if(input$dateAxisQ) { as.POSIXct(Regressor, origin = "1900-01-01") } else { Regressor }, 
                     y = Value,  
                     color = Type)
    ) +
    scale_colour_manual( values = lsGroupColors ) +
    xlab("Regressor")

})

Variance outliers

dfVarOutliers <- reactive({
  qrObj() %>% 
    QRMonFindVarianceAnomalies( outlierIdentifier = varianceOutlierIdentifier(), positionsQ = FALSE ) %>% 
    QRMonTakeValue
})

renderPlot( expr = {

  if( nrow(dfVarOutliers()) == 0 ) {
    dfPlotData <- cbind( Type = "Data", dataset() )
  } else {
    dfPlotData <-  rbind( cbind( Type = "Data", dataset() ), 
                          cbind( Type = "VarianceOutliers", dfVarOutliers() ) )
  }

  ggplot( dfPlotData ) + 
    geom_point( aes( x = if(input$dateAxisQ) { as.POSIXct(Regressor, origin = "1900-01-01") } else { Regressor }, 
                     y = Value, 
                     color = Type ) ) +
    scale_colour_manual( values = lsGroupColors ) +
    xlab("Regressor")

})