inst/shiny/utils.R

In sstModel: Swiss Solvency Test (SST) Standard Models

#' Generates a plot from a vector of simulations.
#' Displays an histogram and a curve of the density.
#' Displays value at risk (orange line) and expected shortfall (green area)
#' for the vector.
#'
#' @param v The vector of simulations.
#'
#' @return None (intended for side effect)
#'
plotDensity <- function(v) {

  q = quantile(v, 0.01)
  d <- density(v)
  x1 <- min(d$x)
  hist(v, freq = FALSE, breaks = 100, main = NA, xlab = "\U0394RBC")
  lines(d, col = "red")
  abline(v = q, col = "orange")
  x2 = max(which(d$x <= q))
  with(d, polygon(x=c(x[c(0:x2, x2)]), y= c(y[0:x2], 0), col="#038000AD", border = NA))
  legend("topright", legend = c("Value at risk", "Expected shortfall"), col = c("orange", "#038000"), lty = c(1, 0), pch = c(NA, 22), pt.bg = c(NA, "#038000"), pt.cex = 2)

}

#' Computes lengths of a summary, lengths of data.fram will be 0,
#' as they are considered as non nested elements. Lists will have their
#' lengths as length.
#'
#' @param summary The summary generated by \link[sstModel]{summary.sstOutput}
#'
#' @return A list of integers.
#'
summaryLengths <- function(summary) {
  lapply(summary, function(x) if(is.data.frame(x)) 0 else length(x))
}

#' Formats an id for tables, the results will be in the form:
#' "name#index" where index is an integer.
#'
#' @param name The name
#'
#' @param index The index for the id.
#'
#' @return A formatted character stirng.
formatTableId <- function(name, index) {
  paste0(name, "#", index)
}

#' Reads a copyright from a file formats it for HTML display.
#'
#' @param noticeName The filename of the notice to open the file.
#'
#' @return A formatted HTML string.
readNotice <- function(noticeName) {
  if(identical(noticeName, "sstModel")) {
    paste(
      gsub(">", "&gt;", gsub("<", "&lt;", readLines(system.file("COPYRIGHT/COPYRIGHT", package = "sstModel")))),
      collapse = "<br>"
    )
  } else {
    paste(
      gsub(">", "&gt;", gsub("<", "&lt;", readLines(system.file(paste0("COPYRIGHT/notices/", gsub(" ", "_", noticeName)), package = "sstModel")))),
      collapse = "<br>"
    )
  }
}

#' Reads a license from a file formats it for HTML display.
#'
#' @param noticeName The filename of the license to open the file.
#'
#' @return A formatted HTML string.
readLicense <- function(licenseName) {
  paste(
    gsub(">", "&gt;", gsub("<", "&lt;", readLines(system.file(paste0("COPYRIGHT/licenses/", gsub(" ", "_", licenseName)), package = "sstModel")))),
    collapse = "<br>"
  )
}

#' Generate a simplified version of a \link[sstModel]{sstOutput},
#' this prevents some memory issues when making copies by function calls.
#'
#' @param sstOutput A \link[sstModel]{sstOuput}
#'
#' @return A list containing only essentials figures from the output.
simpleOutputs <- function(sstOutput) {
  res <- list()
  res$noScenario <- list(
    sstRatio = sstModel::sstRatio(sstOutput),
    riskCapital = sstModel::riskCapital(sstOutput),
    rtkg = sstOutput$rtkg,
    mvm = sstModel::marketValueMargin(sstOutput)
  )

  if(sstModel::containsScenario(sstOutput)) {
    res$scenario <- list(
      sstRatio = sstModel::sstRatio(sstOutput, with.scenario = T),
      riskCapital = sstModel::riskCapital(sstOutput, with.scenario = T),
      rtkg = sstOutput$rtkg,
      mvm = sstModel::marketValueMargin(sstOutput, with.scenario = T)
    )
  }
  res
}

#' Transform a ratio into a percent formatted string.
#'
#' @param x An integer in [0,1]
#'
#' @return A formatted percent string.
ratioToPercent <- function(x) {
  paste0(round(x*100, digits = 2), "%")
}

#' Formats a summary using the ratio to percent function.
#' Every entry whose name contains the ratio word will be converted
#' to a percentage for display
#'
#' @param df A data.frame, should be the one used to render tables in UI.
#'
#' @return A data.frame whose ratios have been replaced by percents.
formatSummary <- function(df) {
  res1 <- sapply(rownames(df), function(x) {
    if(grepl("ratio ", x, ignore.case = T) || grepl(" ratio", x, ignore.case = T)) {
      ratioToPercent(df[x,1])
    } else {
      df[x,1]
    }
  },
  USE.NAMES = F)
  df[,1] <- res1
  df
}

#' Creates an HTML table from a dataframe and adds title attribute
#' to rows.
#'
#' @param data The data.fram to be used as data input.
#'
#' @param attrs A vector of character strings that should contain the content
#' of the title attirbutes for each row. Should be the same length as data.
#'
#' @param attrname The html attirbute to be filled with the string, for modularity purpose
#' This could be use to add any HTML attirbute to a table row.
#'
#' @return An HTML formatted string to display the table.
htmlTableRowAttribute <- function(data, attrs, attrname = "title") {

  if(!is.data.frame(data)) stop("error")
  if(!is.atomic(attrs)) stop("error")
  if(nrow(data) != length(attrs)) stop("error")

  # Generate the html table without attributes with xtable
  # Invisible to prevent console printing.
  html <- invisible(xtable::print.xtable(
    xtable::xtable(data, align = c("l", "r")),
    type = "html",
    include.rownames = T,
    include.colnames = T,
    html.table.attributes = "class='table table-hover table-bordered'",
    print.results = F
  ))

  # The patter to look for in the HTML table, in our case the <tr> html tag.
  # Could be replaced to look for other html tags.
  pattern <- "<tr>"

  # Flag to detect when we finished parsing.
  finish <- FALSE
  i <- 0

  while(!finish) {
    old.html <- html
    # We don't want to replace the first tag which is used for colnames
    # "####" marks that we don't change the pattern here.
    if(i == 0) {
      html <- sub(pattern, "####", html)
    } else {
      # If the comment is NA, we don't display nothing.
      if(is.na(attrs[i])) {
        html <- sub(pattern, "####", html)
      } else {
        # We replace the tr tag with our tag with the title attribute
        replacement <- paste0("<tr ", attrname, "='", attrs[i], "'>")
        html <- sub(pattern, replacement, html)
      }
    }
    i <- i + 1
    # Termination condition is when an iteration does not modify the string anymore
    if(identical(html, old.html)) {
      finish <- TRUE
    }
  }

  # Replace all non change marks with the original pattern.
  gsub("####", pattern, html)

}

#' Computes the color for an sstRatio box.
#'
#' @param sstRatio an integer
#'
#' @return An string representing a color that can be displayed using CSS.
#'   "red" if sstRatio < 33
#'   "orange" if sstRatio < 80
#'   "yellow" if sstRatio < 100
#'   "green" if sstRatio >= 100
sstRatioColorHelper <- function(sstRatio) {
  if(sstRatio < 33) "red" else if(sstRatio < 80) "orange" else if (sstRatio < 100) "yellow" else "green"
}