R/roll_rates.R

In canarionyc/loanroll: Routines for Parsing and Doing Analysis on Loan Data Files from Fannie Mae

# e <- simpleError("No data")

#' @import data.table
#' @import Matrix
#' @importFrom utils str globalVariables
#' @importFrom forcats fct_collapse
#' @importFrom rlang splice

if(getRversion() >= "2.15.1") utils::globalVariables(c('prev_stat.copy', 'LAST_STAT.copy'))

collapse_states <- function(Data_P, stat_map) {
  stopifnot(is.data.table(Data_P))
  if(all(c('prev_stat.copy', 'LAST_STAT.copy') %in% names(Data_P))){
    Data_P[, c('prev_stat.copy', 'LAST_STAT.copy'):=NULL]
  }
  # browser()

  Data_P[, LAST_STAT.copy:=forcats::fct_collapse(Data_P$LAST_STAT, rlang::splice(stat_map))]
  Data_P[, prev_stat.copy:=forcats::fct_collapse(Data_P$prev_stat, rlang::splice(stat_map))]
}


#' @import data.table
#' @import Matrix

if(getRversion() >= "2.15.1") utils::globalVariables(c('prev_upb.Roll'))

calc_llmon_roll <- function(Data_P, xvar='Monthly.Rpt.Prd',
                            by.vars=NULL, verbose=FALSE) {
  stopifnot(is.data.table(Data_P))
  # browser()


  # llmon_roll.LCount <- Data_P[eval(subset) &!is.na(prev_stat.copy), .SD[,.(
  #   'LCount.Roll'=.N), keyby=c(
  #     'prev_stat.copy',
  #     'LAST_STAT.copy')][,
  #       'LCount.Roll.Rate':=LCount.Roll/sum(LCount.Roll), by=c('prev_stat.copy')],
  #   keyby=c(xvar)]
  #
  #
  # # llmon_roll.LCount <- Data_P[eval(subset) & !is.na(prev_stat),
  # #   make_agg0(.SD, by.vars =c(
  # #     'prev_stat',
  # #     'LAST_STAT'))[,
  # #       'LCount':=LCount/sum(LCount), by=c('prev_stat')],
  # #   keyby=c(xvar)]
  #
  # setkeyv(llmon_roll.LCount, c(xvar, 'prev_stat.copy','LAST_STAT.copy'))
  # if(verbose) str(llmon_roll.LCount)


  llmon_roll.prev_upb <- Data_P[  !is.na(prev_stat.copy), .SD[,list(
    'prev_upb.Roll'=sum(prev_upb, na.rm = TRUE)), keyby=c(
      'prev_stat.copy',
      'LAST_STAT.copy')][,'prev_upb.Roll.Rate':=prev_upb.Roll/sum(prev_upb.Roll),
                         by=c('prev_stat.copy')],
    keyby=c(xvar)]

  #  llmon_roll <- merge(llmon_roll.LCount,llmon_roll.prev_upb)

  llmon_roll <- llmon_roll.prev_upb


  if(xvar=='Monthly.Rpt.Prd') {
    llmon_roll[,  'Monthly.Rpt.Prd':=as.Date( Monthly.Rpt.Prd)]
  }
  setkeyv(llmon_roll, c(xvar, 'prev_stat.copy','LAST_STAT.copy'))
  if(verbose) {
    str(llmon_roll)
  }
  return(llmon_roll)
}

#' @import data.table
#' @importFrom  foreach foreach %do%
#' @importFrom zeallot %<-%
#' @importFrom purrr accumulate
roll_matrices <- function(Data_P,
                          xvar='Monthly.Rpt.Prd', by.vars=NULL,
                          verbose=FALSE)
{

  # browser()
  stopifnot(is.data.table(Data_P))
  if(verbose)print(range(Data_P[[xvar]]))
  llmon_roll.ds <- calc_llmon_roll(Data_P = Data_P,  xvar = xvar, verbose = verbose)
  if(verbose){ print(llmon_roll.ds) }

  make_matrix <- function(ds, verbose=FALSE) {
    mat <- with(ds, {
      rnames <- levels(prev_stat.copy)
      cnames <- levels(LAST_STAT.copy)
      sparseMatrix(
        i=as.integer(prev_stat.copy),
        j=as.integer(LAST_STAT.copy),
        x=prev_upb.Roll.Rate,
        dims = c(length(rnames), length(cnames)),
        dimnames=list(rnames, cnames)

      )})
    for(i in which(rowSums(mat)==0)) { mat[i,i] <- 1.0}
    if(verbose){
      printSpMatrix(mat, col.names = TRUE)
      print(rowSums(mat))
    }
    if(all.equal(rowSums(mat),rep(1, nrow(mat)), check.attributes = FALSE) == FALSE) {
      print(mat)
      stop("mat is wrong")
    }
    return(mat)
  }

  # browser()
  llmon_roll.ds_list <- split(llmon_roll.ds, by=xvar)
  llmon_roll.mat_list <- lapply(llmon_roll.ds_list, make_matrix)
  rm(llmon_roll.ds_list)

  diag_mat <- Diagonal(n=length(levels(Data_P$prev_stat.copy)), x=1.0)
  rownames(diag_mat) <- levels(Data_P$prev_stat.copy)
  colnames(diag_mat) <- levels(Data_P$LAST_STAT.copy)

  llmon_roll_acc.mat_list <- purrr::accumulate( llmon_roll.mat_list , `%*%`, .init= diag_mat)
  llmon_roll.mat_list <- append(llmon_roll.mat_list, diag_mat, after = 0)
  rm(diag_mat)

  stopifnot(length(llmon_roll_acc.mat_list)==length(llmon_roll.mat_list))

  # print.data.frame(stat_acc.dat, digits=4)

  return(list(mat_list=llmon_roll.mat_list, acc.mat_list=llmon_roll_acc.mat_list, ds =llmon_roll.ds))
}

#' @import data.table
#' @importFrom purrr map
#' @importFrom lubridate add_with_rollback
#' @importFrom utils str globalVariables
#'

if(getRversion() >= "2.15.1") utils::globalVariables(c('prev_stat.spvec'))

roll_stat <- function(roll_mats_out, init_stat.spvec, verbose=FALSE) {
  stopifnot(is.data.table(roll_mats_out$ds),
            !is.null(init_stat.spvec))
  # browser()
  if(verbose){
    cat("Initial state:\n"); print(init_stat.spvec)
    printSpMatrix( as(init_stat.spvec,"sparseMatrix"), col.names = TRUE )

  }
  stat_acc.mat_list <- purrr::map( roll_mats_out$acc.mat_list , ~ .y %*% .x, init_stat.spvec)
  if(verbose){
    cat("Last state:\n"); print(last(stat_acc.mat_list))
    cat("Orig face: ", sum(last(stat_acc.mat_list)), "\n")
  }

  xvar <- key(roll_mats_out$ds)[1]
  stat_acc.ds <- data.table( t(sapply(stat_acc.mat_list, as.vector)),
                             keep.rownames = xvar)
  setnames(stat_acc.ds, c(xvar, levels(roll_mats_out$ds$prev_stat.copy)))
  # browser()
  if(xvar=='Monthly.Rpt.Prd') {
    stat_acc.ds[1, 'Monthly.Rpt.Prd'] <- as.character(lubridate::add_with_rollback(as.Date(stat_acc.ds[2, Monthly.Rpt.Prd]), -months(1, abbreviate=TRUE), roll_to_first=TRUE))
    stat_acc.ds[, 'Monthly.Rpt.Prd':=as.Date(Monthly.Rpt.Prd)]
  } else if(xvar=='Loan.Age') {
    stat_acc.ds[1, 'Loan.Age'] <- -1L
    stat_acc.ds[, 'Loan.Age':=as.integer(Loan.Age)]
  }
  setkeyv(stat_acc.ds, c(xvar))

  stat_acc.ds[, 'Dq':=rowSums(.SD), .SDcols=grep("(dq)?[1-9]", colnames(stat_acc.ds), value = TRUE)]
  stat_acc.ds[, 'Cum_Prepay':=rowSums(.SD, na.rm = TRUE), .SDcols=c('P','R', 'L')]
  stat_acc.ds[, 'Cum_Default':=rowSums(.SD, na.rm = TRUE), .SDcols=c('T','S', 'F','N')]

  if(verbose) print(stat_acc.ds, row.names=FALSE)

  return(list(mat_list=stat_acc.mat_list, ds=stat_acc.ds))

}