# R/Triangles.R In edalmoro/ChainLadderQuantileV1: Statistical Methods and Models for Claims Reserving in General Insurance

```## Author: Markus Gesmann
## Copyright: Markus Gesmann, [email protected]
## Date:10/11/2007; 17/09/2008; 16/11/2009

.allisnumeric <- function (x,
what = c("test", "vector"),
extras = c(".", "NA"))
{
# Based on code by Frank Harrell, Hmisc package, licence: GPL >= 2
what <- match.arg(what)
x <- sub("[[:space:]]+\$", "", x)
x <- sub("^[[:space:]]+", "", x)
#xs <- x[x %nin% c("", extras)]
xs <- x[match(x, extras, nomatch = 0) == 0]
isnum <- suppressWarnings(!any(is.na(as.numeric(xs))))
if (what == "test")
isnum
else if (isnum)
as.numeric(x)
else x
}

incr2cum <- function(Triangle, na.rm=FALSE){
if(na.rm){
upper <- col(Triangle) <= ncol(Triangle) + 1 - row(Triangle)
upperna <- which(is.na(Triangle[upper]), arr.ind=TRUE)

Triangle[upper][upperna] <- 0
}
cum <- t(apply(Triangle,1, cumsum))
dimnames(cum) <- dimnames(Triangle)
expos <- attr(Triangle,"exposure")
if (!is.null(expos))
attr(cum,"exposure") <- expos
class(cum) <- c("triangle", "matrix")
cum
}

cum2incr <- function(Triangle){
incr <- cbind(Triangle[,1], t(apply(Triangle,1,diff)))
dimnames(incr) <- dimnames(Triangle)
expos <- attr(Triangle,"exposure")
if (!is.null(expos))
attr(incr,"exposure") <- expos
class(incr) <- c("triangle", "matrix")
incr
}

as.triangle <- function(Triangle, origin="origin", dev="dev", value="value",...){
UseMethod("as.triangle")
}

as.triangle.matrix <- function(Triangle, origin="origin", dev="dev", value="value",...){
class(Triangle) <- c("triangle", "matrix")
if(is.null(dimnames(Triangle))){
dimnames(Triangle) <- list(origin=1:nrow(Triangle), dev=1:ncol(Triangle))
}
names(dimnames(Triangle)) <- c(origin, dev)

if(is.null(dimnames(Triangle)[[origin]])){
dimnames(Triangle)[[origin]] <- 1:nrow(Triangle)
}
if(is.null(dimnames(Triangle)[[dev]])){
dimnames(Triangle)[[dev]] <- 1:ncol(Triangle)
}

storage.mode(Triangle) <- "double"
return(Triangle)
}

as.triangle.data.frame <- function(Triangle, origin="origin", dev="dev", value="value", ...){

#  isDate <- inherits(Triangle[[origin]], "Date")
#
#  if (isDate) {
#    warning("Converting origin from Date to numeric")
#    Triangle[[origin]] <- as.numeric(Triangle[[origin]])
#  }

fmla <- as.formula(paste(origin, "~", dev))
matrixTriangle <- acast(Triangle, fmla, fun.aggregate = sum,
value.var = value, fill = as.numeric(NA))
names(dimnames(matrixTriangle)) <- c(origin, dev)

class(matrixTriangle) <- c("triangle", "matrix")
return(matrixTriangle)
}

## Copyright notice for function 'triangle' only
## Author: Vincent Goulet
## Copyright: Vincent Goulet, [email protected]
## Date: 23/05/2018
triangle <- function(..., bycol = FALSE, origin = "origin", dev = "dev", value = "value"){
x <- list(...)

if (length(x) == 1L) {
## 'len' contains the number of development periods (when filling
## by row) or origin periods (when filling by column). In the case
## where there is only one vector of data provided, 'len' is the
## positive root of n(n + 1)/2 = k, where k is the number of data
## points.
len <- (-1 + sqrt(1 + 8 * length(x[[1L]])))/2

## Error if 'len' is not an integer, otherwise it is just too
## complicated to try infer what user wants. (Test taken from
## ?is.integer.)
if (abs(len - round(len)) > .Machine\$double.eps^0.5)
stop("invalid number of data points for a triangle")

## Rearrange the data vector in a list of vectors suitable to
## build a 'len x len' triangle.
s <- seq_len(len)                   # avoid generating twice
x <- split(x[[1L]], rep(s, rev(s)))
} else {
## If more than one data vector is provided in argument, the
## number of development or origin periods is derived from the
## *first* vector (this avoids looking at the length of each
## and every element to find the maximum).
len <- length(x[[1L]])
}

## Extend each data vector to length 'len' by filling with NAs and
## put into matrix form at the same time; dimension names will be in
## place thanks to 'sapply'.
x <- sapply(x, function(x) { length(x) <- len; x })

## Turn to 'as.triangle' to complete the work.
as.triangle.matrix(if (bycol) x else t(x),
origin = origin, dev = dev, value = value)
}

as.data.frame.triangle <- function(x, row.names=NULL, optional, lob=NULL, na.rm=FALSE,...){

longTriangle <- .as.LongTriangle(x, na.rm)
if(is.null(row.names))
rownames(longTriangle) <- paste(longTriangle[,1], longTriangle[,2], sep="-")
if(!is.null(lob))
longTriangle\$lob=lob

class(longTriangle) <- c("long.triangle", "data.frame")
return(longTriangle)
}

plot.triangle <- function(x,type="b",
xlab="dev. period",
ylab=NULL, lattice=FALSE,...){
.x <- x
class(.x) <- "matrix"
if(!lattice){
matplot(t(.x),type=type,
xlab=xlab,
ylab=ifelse(is.null(ylab), deparse(substitute(x)), ylab),...)
}else{
df <- as.data.frame(as.triangle(.x))
xyplot(value ~ dev | factor(origin), data=df, type=type,
as.table=TRUE, xlab=xlab, ylab=ylab, ...)
}
}

print.triangle <- function(x, ...) {
class(x) <- tail(class(x), -1)
NextMethod(x, ...)
}

.as.MatrixTriangle <- function(x, origin="origin", dev="dev", value="value"){
## x has to be a data.frame with columns: origin, dev and value
x <- x[,c(origin, dev, value)]
names(x) <- c("origin", "dev", "value")

z <- reshape(x, timevar="dev", v.names="value", idvar="origin", direction="wide")

z <- z[order(z\$origin), ]

.origin.names <- z\$origin
z <- z[,-1]

names(z) <- gsub("value.", "",names(z))
.dev.names <- as.numeric(as.character(names(z)))
z <- z[,order(.dev.names)]

z<- as.matrix(z)
dimnames(z) <- list(origin=.origin.names, dev=sort(.dev.names))

names(dimnames(z)) <- c(origin, dev)
return(z)
}

as.LongTriangle1 <- function(Triangle, varnames = names(dimnames(Triangle)), ...,
na.rm = TRUE, as.is = TRUE, value.name = "value") {
if (!inherits(Triangle, "matrix")) stop("asLongTriangle only works for matrices")
if (is.null(varnames)) varnames <- c("origin", "dev")
else {
if (is.na(varnames[1L])) varnames[1L] <- "origin"
if (is.na(varnames[2L])) varnames[2L] <- "dev"
}
y <- reshape2::melt(Triangle, varnames = varnames, ..., na.rm = na.rm, as.is = as.is,
value.name = value.name)
names(y)[1:2] <- varnames
y
}

as.LongTriangle <- function (Triangle, varnames = names(dimnames(Triangle)),
value.name = "value", na.rm = TRUE) {
if (!inherits(Triangle, "matrix")) stop("asLongTriangle only works for matrices")
if (is.null(varnames)) varnames <- c("origin", "dev")
else {
if (is.na(varnames[1L])) varnames[1L] <- "origin"
if (is.na(varnames[2L])) varnames[2L] <- "dev"
}
namecols <- setNames(expand.grid(dimnames(Triangle), KEEP.OUT.ATTRS = FALSE,
stringsAsFactors = TRUE), varnames)
if (na.rm) {
isna <- is.na(Triangle)
namecols <- namecols[!isna,]
Triangle <- Triangle[!isna]
}
y <- cbind(namecols, setNames(data.frame(c(Triangle)), value.name))
#   class(y) <- c("long.triangle", "data.frame")
y
}

.as.LongTriangle <- function(Triangle, na.rm=FALSE){
# 3/20/2013
# Difference from old version: preserves names(dimnames) to be column names
# in the data.frame rather than forcing 'origin' and 'dev'
x <- Triangle
nms <- names(dimnames(x))
.dev <- try(as.numeric(dimnames(x)[[nms[2L]]]))
#  .origin <- try(as.numeric(dimnames(x)[[nms[1L]]]))
.origin <- dimnames(x)[[nms[1L]]]
if(class(dimnames(x)[[nms[2L]]]) %in% "character"){
if(.allisnumeric(dimnames(x)[[nms[2L]]])){
.dev <- try(as.numeric(dimnames(x)[[nms[2L]]]))
}else{
.dev <- seq(along=(dimnames(x)[[nms[2L]]]))
warning(paste(
c("Development period was a character and has been set to:\n",.dev),
collapse = " "))
}
}else{
.dev <- try(as.numeric(dimnames(x)[[nms[2L]]]))
}
#  if(any(is.na(c(.origin, .dev)))){
#    stop(paste("The origin and dev. period columns have to be of type numeric or a character",
#               "which can be converted into numeric.\n"))
#  }
lx <- expand.grid(origin=.origin, dev=.dev, stringsAsFactors = FALSE)
##    lx <- expand.grid(origin=dimnames(x)\$origin, dev=dimnames(x)\$dev)
lx\$value <- as.vector(x)
if(na.rm){
lx <- na.omit(lx)
}
if (!is.null(nms)) {
if (!is.na(nms[1L])) names(lx)[1L] <- nms[1L]
if (!is.na(nms[2L])) names(lx)[2L] <- nms[2L]
}
return(lx)
}

# A coefficients method to quickly pull out the factors from a ChainLadder model