inst/shiny/sstTestResultsUi.R

In sstModel: Swiss Solvency Test (SST) Standard Models

source("utils.R", local = T)

#' Creates an SST Test results page layout.
#'
#' @param ... Lists generated by \code{shiny::fluidRow} functions.
#'
#' @return A \code{shiny::fluidPage} containing all items passed
#' in \code{...} that can be used in a \code{shinydashboard::tabItems} function.
#'
sstTestResults.pageLayout <- function(...) {
  fluidPage(
    id = "sstTestResults",
    fluidRow(
      column(
        width = 12,
        tags$h2("Simulations results")
      )
    ),
    actionButton("introJsResults", label = "Interactive help", onclick = "resultsIntro()"),
    ...
  )
}

#' Creates an SST Test modular \code{shiny::fluidRow} to display plots
#' and SST simulation results.
#'
#' @param simpleOutputs A list of 2 simplified output containing the values
#' from \code{sstModel::sstOutput} without the simulations, with or without
#' scenario.
#'
#' @param baseCurrency The base currency used for the simulation.
#'
#' @param plotParams A list of 3 logical values indicating which plots
#' shall be displayed.
#'
#' @return A \code{shiny::fluidRow} containing either one or two
#' \code{resultColumn} depending on the parameters.
#'
sstTestResults.resultColumns <- function(simpleOutputs,
                          baseCurrency,
                          plotParams) {
  if(plotParams$scenario) {
      res <- list(
      sstTestResults.resultColumn(simpleOutput = simpleOutputs$noScenario,
                                  baseCurrency = baseCurrency,
                                  plotParams = plotParams,
                                  isScenario = FALSE,
                                  width = 6
      ),
      sstTestResults.resultColumn(simpleOutput = simpleOutputs$scenario,
                                  baseCurrency = baseCurrency,
                                  plotParams = plotParams,
                                  isScenario = TRUE,
                                  width = 6
      )
    )
  } else {
    res <- sstTestResults.resultColumn(simpleOutput = simpleOutputs$noScenario,
                                       baseCurrency = baseCurrency,
                                       plotParams = plotParams
    )
  }
  fluidRow(res)
}

#' Creates an SST Test modular \code{shiny::column} to display plots
#' and SST simulation results. Scenario columns contains the drbc
#' and scenario risk plot. Normal columns contains the drbc (without scenario),
#' insurance and market risks plot.
#'
#' @param simpleOutput A implified output containing the values
#' from \code{sstModel::sstOutput} without the simulations, with or without
#' scenario.
#'
#' @param baseCurrency The base currency used for the simulation.
#'
#' @param plotParams A list of 3 logical values indicating which plots
#' shall be displayed.
#'
#' @param isScenario A logical value indicating whether to build
#' a scenario column or normal column.
#'
#' @param width The width of the column generated, defaults to 12 (full width)
#'
#' @return A \code{shiny::column}.
#'
sstTestResults.resultColumn <- function(simpleOutput,
                         baseCurrency,
                         plotParams,
                         isScenario = FALSE,
                         width = 12) {
  sstRatio <- round(simpleOutput$sstRatio * 100)
  sstRatioColor <- sstRatioColorHelper(sstRatio)
  id <- if(isScenario) "scenario" else "noScenario"

  # Defines tabBox depending on plotParams and isScenario
  plotBox <- if(isScenario) {
    sstTestResults.tabBox(
      isScenario,
      tabPanel("\U0394RBC", plotOutput("insMarScePlot")),
      tabPanel("Scenario Risk", plotOutput("scePlot"))
    )
  } else if (plotParams$insurance && plotParams$marketRisk) {
    sstTestResults.tabBox(
      isScenario,
      tabPanel("\U0394RBC", plotOutput("insMarPlot")),
      tabPanel("Insurance Risk", plotOutput("insPlot")),
      tabPanel("Market Risk", plotOutput("marPlot"))
    )
  } else if (!plotParams$insurance) {
    sstTestResults.tabBox(
      isScenario,
      tabPanel("\U0394RBC", plotOutput("insMarPlot")),
      tabPanel("Market Risk", plotOutput("marPlot"))
    )
  } else {
    sstTestResults.tabBox(
      isScenario,
      tabPanel("\U0394RBC", plotOutput("insMarPlot")),
      tabPanel("Insurance Risk", plotOutput("insPlot"))
    )
  }

  column(
    id = id,
    width = width,
    plotBox,
    fluidRow(
      id = if(isScenario) NULL else "highlightBoxes",
      sstTestResults.moneyBox("Risk bearing capital", simpleOutput$rtkg, baseCurrency, icon("line-chart"), "blue"),
      sstTestResults.moneyBox("One-year risk capital", simpleOutput$riskCapital, baseCurrency, icon("line-chart"), "blue"),
      sstTestResults.moneyBox("MVM", simpleOutput$mvm, baseCurrency, icon("pie-chart"), "blue"),
      sstTestResults.percentBox("SST ratio", sstRatio, icon("percent"), sstRatioColor)
    )
  )
}

#' Creates an \code{shinydashboard::tabBox} container for plot results.
#'
#' @param isScenario A logical indicating whether the box is used to
#' display with or without scenario results.
#'
#' @param ... Additional \code{shinydashboard::tabPanel} parameters to
#' include in the \code{shinydashboard::tabBox}.
#'
#' @return A \code{shiny::fluidRow}.
#'
sstTestResults.tabBox <- function(isScenario, ...) {
  fluidRow(
    id = if(isScenario) NULL else "plotBox",
    tags$h3(if(isScenario) "With scenario" else "Without scenario"),
    shinydashboard::tabBox(
      width = 12,
      ...
    )
  )
}

#' Creates an \code{shinydashboard::infoBox} container to display to
#' display percent values.
#'
#' @param title The title of the box
#'
#' @param val The value of the box (should be a percentage)
#'
#' @param icon The icon for the box, generated by \code{shiny::icon}
#'
#' @param color The color of the box.
#'
#' @return A \code{shinydashboard::infoBox}.
#'
sstTestResults.percentBox <- function(title,
                       val,
                       icon,
                       color) {
  div(
    # Manually added boostrap classes to the div for better
    # responsiveness. Prevents the colored boxes of solvency figures
    # from being unreadable when the window is too small.
    class = "col-lg-6 col-md-12",
    fluidRow(
      shinydashboard::infoBox(
        value = paste0(val, " %"),
        title = title,
        icon = icon,
        width = 12,
        color = color,
        fill = TRUE
      )
    )
  )

}

#' Creates an \code{shinydashboard::infoBox} container to display to
#' display financial values.
#'
#' @param title The title of the box
#'
#' @param val The value of the box (should be a financial value)
#'
#' @param currency A string representing a currency that will be appended
#' to the value of the box.
#'
#' @param icon The icon for the box, generated by \code{shiny::icon}
#'
#' @param color The color of the box.
#'
#' @return A \code{shinydashboard::infoBox}.
#'
sstTestResults.moneyBox <- function(title,
                     val,
                     currency,
                     icon,
                     color) {
  div(
    # Manually added boostrap classes to the div for better
    # responsiveness. Prevents the colored boxes of solvency figures
    # from being unreadable when the window is too small.
    class = "col-lg-6 col-md-12",
    fluidRow(
      shinydashboard::infoBox(
        value = paste0(
          "Mio. ",
          currency,
          " ",
          prettyNum(round(abs(val)), big.mark = "'", scientific = FALSE)
        ),
        title = title,
        icon = icon,
        width = 12,
        color = color,
        fill = TRUE
      )
    )
  )
}

#' Creates an SST Test modular \code{shiny::fluidRow} to display a table
#' of standalones.
#'
#' @param summary The summary of the sstOuput, generarted by
#' \code{sstModel::summary(sstOutput)}
#'
#' @return A \code{shiny::fluidRow} containing different \code{shinydashboard::box}
#'
sstTestResults.standalonesTables <- function(summary) {

  # Computes the names of the a list type datastructure,
  # names(x) would return colnames for data.frame otherwise.
  xnames <- function(x) {
    if(is.data.frame(x)) {
      rownames(x)
    } else {
      names(x)
    }
  }

  lengths <- summaryLengths(summary)

  fluidRow(lapply(names(lengths), function(x) sstTestResults.standalonesTable(x, lengths[[x]], xnames(summary[[x]]))))
}

#' Creates an SST Test modular \code{shiny::fluidRow} to display a table
#' of standalones.
#'
#' @param title A character string that will be used as title for the box
#' and to compute ids for the tables.
#'
#' @param ntables THe number of tables in the box.
#'
#' @param names A character vector containing the names of each table.
#'
#' @return A \code{shinydashboard::box} containing a \code{shiny::dataTableOutput}
#'
sstTestResults.standalonesTable <- function(title, ntables, names) {
    # If ntables > 0 it means that tables to render may have different titles
    # than title, therefore we would manually add the subtitle for the table.
    list <- if(ntables > 0) {
      lapply(seq(to = ntables), function(x) {
        list(
          tags$h4(names[x]),
          uiOutput(formatTableId(title, x), width = "100%")
        )
      })
    # Otherwise it means the box can only contain one table, so no
    # subtitles are needed.
    } else {
      uiOutput(title, width = "100%")
    }
    shinydashboard::box(
      title = title,
      solidHeader = TRUE,
      status = "primary",
      width = 12,
      class = "tableBox",
      style="overflow: auto;",
      list
    )
}