R/rebalance.R

In enricoschumann/PMwR: Portfolio Management with R

## -*- truncate-lines: t; -*-
## Copyright (C) 2008-23  Enrico Schumann

rebalance <- function(current,
                      target,
                      price,
                      notional = NULL,
                      multiplier = 1,
                      truncate = TRUE,
                      match.names = TRUE,
                      fraction = 1,
                      drop.zero = FALSE,
                      current.weights = FALSE,
                      target.weights = TRUE##,
                      ## algorithm = NULL,
                      ## algorithm.control = NULL
                      ) {

    if (inherits(current, "position")) {
        instr <- attr(current, "instrument")
        current <- as.numeric(current)
        names(current) <- instr
        current.weights <- FALSE
    }
    if (inherits(target, "position")) {
        instr <- attr(target, "instrument")
        target <- as.numeric(target)
        names(target) <- instr
        target.weights <- FALSE
    }

    if (length(current) == 1L &&
        current == 0 &&
        is.null(notional)) {

        stop(sQuote("notional"), " must be specified")

    }
    if (!match.names &&
        length(current) == 1L &&
        current == 0 &&
        length(target) == 1L) {

        ## current == 0 and target is a single number
        current <- rep.int(current, length(price))
        target <- rep.int(target, length(price))
        names(current) <- names(target) <- names(price)
    }

    if (length(current) == 1L &&
        current == 0 &&
        is.null(names(current))) {

        current <- rep.int(current, length(target))
        names(current) <- names(target)
    }

    if (length(target) == 1L &&
        is.null(names(target))) {
        target <- rep.int(target, length(current))
        names(target) <- names(current)
    }

    if (is.null(names(multiplier)) &&
        length(multiplier) == 1L) {
        multiplier <- rep(multiplier, length(price))
        names(multiplier) <- names(price)
    }

    if (match.names) {

        ## special case: current and target are of
        ## length 1 and unnamed
        if (length(current) == 1L &&
            current == 0 &&
            is.null(names(current)) &&
            length(target) == 1L &&
            is.null(names(target))) {
            current <- rep(0, length(price))
            target <- rep(target, length(price))
            names(current) <- names(target) <- names(price)
        }

        if (is.null(names(price)) ||
            (is.null(names(current)) && !identical(unname(current), 0)) ||
            is.null(names(target))) {
            stop(sQuote("match.names"),
                 " is TRUE but vectors are not named")
        }

        if (any(miss.name <- is.na(match(names(current),
                                         names(price))))) {
            warning("instrument in current without price: ",
                    if (sum(miss.name) > 3) "\n",
                    paste(names(current)[miss.name],
                          collapse = if (sum(miss.name) > 3) "\n" else ", "),
                    immediate. = TRUE)
        }
        if (any(miss.name <- is.na(match(names(target),
                                         names(price))))) {
            warning("instrument in target without price: ",
                    if (sum(miss.name) > 3) "\n",
                    paste(names(current)[miss.name],
                          collapse = if (sum(miss.name) > 3) "\n" else ", "),
                    immediate. = TRUE)
        }
        if (any(miss.price <- is.na(price))) {
            warning("NAs in prices: ",
                    if (sum(miss.price) > 3) "\n",
                    paste(names(price)[miss.price],
                          collapse = if (sum(miss.price) > 3) "\n" else ", "),
                    immediate. = TRUE)
        }

        ## set up vectors that match __by position__

        ## ---- collect all relevant names
        all.names <- sort(unique(
            c(names(target), names(current))))

        ## ---- collect relevant multipliers
        miss.mult <- !all.names %in% names(multiplier)
        if (any(miss.mult)) {
            warning("instrument without multiplier: ",
                    if (sum(miss.mult) > 3) "\n",
                    paste(all.names[miss.mult],
                          collapse = if (sum(miss.mult) > 3) "\n" else ", "),
                    immediate. = TRUE)
        }

        multiplier <- multiplier[all.names]
        target_ <- current_ <- numeric(length(all.names))
        current_[match(names(current), all.names)] <- current
        target_[match(names(target), all.names)] <- target
        current <- current_
        target <- target_
        price <- price[all.names]

    } else {
        if ( length(current) != length(target) ||
             length(current) != length(price)  ||
             length(target)  != length(price) ) {
                stop(sQuote("current"), ", ",
                     sQuote("target"), " and ",
                     sQuote("price"), " must have same length")
        }
        all.names <- NA
    }

    if (is.null(notional)) {
        if (current.weights && target.weights)
            stop(sQuote("notional"), " must be provided")
        if (target.weights)
            notional <- sum(current * price * multiplier)
        else if (current.weights)
            notional <- sum(target  * price * multiplier)
    }

    ## if (!is.null(algorithm)) {
        ##
    ## }

    if (current.weights)
        current <- notional*current/
            price/multiplier

    if (target.weights)
        target <- notional*target/
            price/multiplier
    if (truncate) {
        target <- round(trunc(target/10^(-truncate))*10^(-truncate))
        diff <- fraction*(target - current)
        diff <- round(trunc(diff/10^(-truncate))*10^(-truncate))
    } else
        diff <- fraction*(target - current)
    rbl <- data.frame(instrument = all.names,
                      price = price,
                      current = current,
                      target = target,
                      difference = diff,
                      stringsAsFactors = FALSE)
    attr(rbl, "notional") <- notional
    attr(rbl, "match.names") <- match.names
    attr(rbl, "multiplier") <-  multiplier

    if (drop.zero)
        rbl <- rbl[rbl$current != rbl$target, ]
    class(rbl) <- c("rebalance", "data.frame")
    rbl
}

print.rebalance <- function(x, ..., drop.zero = TRUE) {

    sp <- getOption("scipen")
    on.exit(options(scipen = sp))
    options(scipen = 1e8)

    all.names <- x[["instrument"]]
    if (all(is.na(all.names)))
        all.names <- seq_along(x$current)

    multiplier <- attr(x, "multiplier")
    multiplier <- if (attr(x, "match.names"))
        multiplier[x$instrument]
    else
        multiplier[as.numeric(row.names(x))]

    df <- data.frame(price   = x$price,
                     current = x$current,
                     value   = x$current * x$price * multiplier,
                     `%`     = format(100*x$current * x$price /
                                      c(attr(x, "notional")),
                                      nsmall = 1, digits = 1),
                     `  `    = format("     ", justify = "centre"),
                     target  = x$target,
                     value   = x$target * x$price * multiplier,
                     `%`     = format(100*x$target * x$price /
                                      c(attr(x, "notional")),
                                      nsmall = 1, digits = 1),
                     `  `    = format("     ", justify = "centre"),
                     order   = x$difference,
                     row.names = all.names,
                     check.names = FALSE)

    if (drop.zero)
        df <- df[df$current != df$target, ]
    print(df, ...)

    cat("\nNotional: ", attr(x, "notional"),
        ".  Target net amount : ", sum(x$target * x$price * multiplier),
        ".  Turnover (2-way): ", sum(abs(x$current - x$target) * x$price * multiplier),
        ".\n", sep = "")
    invisible(x)
}

replace_weight <- function(weights, ..., prefix = TRUE, sep = "::") {
    repl <- list(...)
    for (i in seq_along(repl)) {
        nw <- names(weights)
        ii <- match(names(repl)[[i]], nw, nomatch = 0)
        if (ii > 0) {
            w_new <- weights[[ii]]*repl[[i]]
            if (prefix)
                names(w_new) <- paste0(names(weights)[[ii]], sep,
                                       names(repl[[i]]))
            tmp <- c(weights[0:(ii-1L)],
                         w_new)
            if (ii != length(weights))
                weights <- c(tmp, weights[ (ii+1L) : length(weights)])
            else
                weights <- tmp
        }
    }
    weights
}