# Load packages

# Core
library(tidyverse)
library(tidyquant)
library(readr)

# Time series
library(lubridate)
library(tibbletime)

# modeling
library(broom)

Goal

Examine how each asset contributes to portfolio standard deviation. This is to ensure that our risk is not concentrated in any one asset.

three stocks: “LULU”, “NKE”, “UA” from 2019-12-31 to 2024-12-31

1 Import stock prices

symbols <- c("LULU", "NKE", "UA")

prices <- tq_get(x    = symbols,
                 get  = "stock.prices",    
                 from = "2019-12-31",
                 to   = "2024-12-31")

2 Convert prices to returns

asset_returns_tbl <- prices %>%
    
    group_by(symbol) %>%
    
    tq_transmute(select     = adjusted, 
                 mutate_fun = periodReturn, 
                 period     = "monthly",
                 type       = "log") %>%
    
    slice(-1) %>%
    
    ungroup() %>%
    
    set_names(c("asset", "date", "returns"))

3 Component Contribution Step-by-Step

# Transform data into wide form
asset_returns_wide_tbl <- asset_returns_tbl %>%

    pivot_wider(names_from = asset, values_from = returns) %>%

    column_to_rownames(var = "date")

asset_returns_wide_tbl
##                     LULU           NKE           UA
## 2020-01-31  3.278008e-02 -0.0507166399 -0.065721073
## 2020-02-28 -9.630903e-02 -0.0718008608 -0.364019686
## 2020-03-31 -1.371321e-01 -0.0771934075 -0.437213718
## 2020-04-30  1.646690e-01  0.0522716859  0.139869820
## 2020-05-29  2.947939e-01  0.1253848993 -0.164996806
## 2020-06-30  3.891950e-02 -0.0053910627  0.117500270
## 2020-07-31  4.260364e-02 -0.0044977378  0.070951695
## 2020-08-31  1.430722e-01  0.1387493653 -0.069821086
## 2020-09-30 -1.315294e-01  0.1151080253  0.106038224
## 2020-10-30 -3.108192e-02 -0.0444661042  0.217436186
## 2020-11-30  1.479976e-01  0.1148921669  0.173699094
## 2020-12-31 -6.180875e-02  0.0510473909  0.022427030
## 2021-01-29 -5.720407e-02 -0.0573124878  0.006030179
## 2021-02-26 -5.310761e-02  0.0108991970  0.195373420
## 2021-03-31 -1.607435e-02 -0.0141220616  0.014184543
## 2021-04-30  8.903350e-02 -0.0020338080  0.075615931
## 2021-05-28 -3.688141e-02  0.0305598762 -0.043630240
## 2021-06-30  1.217604e-01  0.1240974899 -0.026044511
## 2021-07-30  9.207433e-02  0.0809136943 -0.058204247
## 2021-08-31  0.000000e+00 -0.0150255737  0.135384644
## 2021-09-30  1.125659e-02 -0.1260498377 -0.135384644
## 2021-10-29  1.410610e-01  0.1414101125  0.074760005
## 2021-11-30 -2.520723e-02  0.0115890355  0.061123031
## 2021-12-31 -1.491421e-01 -0.0135064168 -0.106634582
## 2022-01-31 -1.594356e-01 -0.1183306076 -0.120628053
## 2022-02-28 -4.228872e-02 -0.0809942181 -0.022771361
## 2022-03-31  1.323938e-01 -0.0124014782 -0.004488606
## 2022-04-29 -2.945232e-02 -0.0760993402 -0.092166084
## 2022-05-31 -1.919610e-01 -0.0480486173 -0.380411596
## 2022-06-30 -7.107189e-02 -0.1484560401 -0.246612676
## 2022-07-29  1.301740e-01  0.1173045103  0.085911426
## 2022-08-31 -3.456703e-02 -0.0765608361 -0.084593004
## 2022-09-30 -7.043217e-02 -0.2445217747 -0.241761124
## 2022-10-31  1.629624e-01  0.1088672398  0.095920107
## 2022-11-30  1.448074e-01  0.1685056503  0.284628674
## 2022-12-30 -1.714789e-01  0.0676659366  0.022676687
## 2023-01-31 -4.305100e-02  0.0845228122  0.200466799
## 2023-02-28  7.531549e-03 -0.0694250361 -0.214011011
## 2023-03-31  1.636874e-01  0.0347433234 -0.031162413
## 2023-04-28  4.231129e-02  0.0327266577 -0.059160252
## 2023-05-31 -1.350629e-01 -0.1855463631 -0.200394345
## 2023-06-30  1.312920e-01  0.0506911343  0.019564223
## 2023-07-31  7.925387e-05  0.0001810283  0.100580111
## 2023-08-31  7.186256e-03 -0.0818938012 -0.074108002
## 2023-09-29  1.134488e-02 -0.0583950870 -0.076902950
## 2023-10-31  2.020381e-02  0.0721113527  0.007806396
## 2023-11-30  1.270808e-01  0.0704384142  0.175037452
## 2023-12-29  1.348259e-01 -0.0121757339  0.086249621
## 2024-01-31 -1.192363e-01 -0.0670408903 -0.120781571
## 2024-02-29  2.882129e-02  0.0233633648  0.143280990
## 2024-03-28 -1.787099e-01 -0.0970691260 -0.179048246
## 2024-04-30 -8.004268e-02 -0.0184713554 -0.090838385
## 2024-05-31 -1.447982e-01  0.0297923709  0.065305107
## 2024-06-28 -4.353134e-02 -0.2280934091 -0.063772504
## 2024-07-31 -1.439253e-01 -0.0067896588  0.039043961
## 2024-08-30  3.126622e-03  0.1070688666  0.094104483
## 2024-09-30  4.476843e-02  0.0636339983  0.113902967
## 2024-10-31  9.334832e-02 -0.1363798119 -0.056595614
## 2024-11-29  7.362354e-02  0.0210400330  0.104474087
## 2024-12-30  1.803913e-01 -0.0486306069 -0.173919168
# Covariance of asset returns
covariance_matrix <- cov(asset_returns_wide_tbl)

covariance_matrix
##             LULU         NKE          UA
## LULU 0.012248023 0.005004496 0.005967638
## NKE  0.005004496 0.008403537 0.007869281
## UA   0.005967638 0.007869281 0.022285695
# Standard deviation of portfolio
# Summarizes how much each asset's returns vary with those of other assets within the portfolio into a single number
w <- c(0.45, 0.35, 0.2)

sd_portfolio <- sqrt(t(w) %*% covariance_matrix %*% w)
sd_portfolio
##            [,1]
## [1,] 0.09029605
# Component contribution
# Similar to the formula for sd_portfolio
# Mathematical trick to summarize the same, sd_portfolio, by asset instead of a single number
component_contribution <- (t(w) %*% covariance_matrix * w) / sd_portfolio[1,1]
component_contribution
##            LULU        NKE         UA
## [1,] 0.04214493 0.02623028 0.02192084
rowSums(component_contribution)
## [1] 0.09029605
# Component contribution in percentage
component_percentages <- (component_contribution / sd_portfolio[1,1]) %>%
    round(3) %>%
    as_tibble()

component_percentages
## # A tibble: 1 × 3
##    LULU   NKE    UA
##   <dbl> <dbl> <dbl>
## 1 0.467  0.29 0.243
component_percentages %>%

    as_tibble() %>%
    gather(key = "asset", value = "contribution")
## # A tibble: 3 × 2
##   asset contribution
##   <chr>        <dbl>
## 1 LULU         0.467
## 2 NKE          0.29 
## 3 UA           0.243

4 Component Contribution with a Custom Function

# Transform data into wide form
asset_returns_wide_tbl <- asset_returns_tbl %>%

    pivot_wider(names_from = asset, values_from = returns) %>%

    column_to_rownames(var = "date")

asset_returns_wide_tbl
##                     LULU           NKE           UA
## 2020-01-31  3.278008e-02 -0.0507166399 -0.065721073
## 2020-02-28 -9.630903e-02 -0.0718008608 -0.364019686
## 2020-03-31 -1.371321e-01 -0.0771934075 -0.437213718
## 2020-04-30  1.646690e-01  0.0522716859  0.139869820
## 2020-05-29  2.947939e-01  0.1253848993 -0.164996806
## 2020-06-30  3.891950e-02 -0.0053910627  0.117500270
## 2020-07-31  4.260364e-02 -0.0044977378  0.070951695
## 2020-08-31  1.430722e-01  0.1387493653 -0.069821086
## 2020-09-30 -1.315294e-01  0.1151080253  0.106038224
## 2020-10-30 -3.108192e-02 -0.0444661042  0.217436186
## 2020-11-30  1.479976e-01  0.1148921669  0.173699094
## 2020-12-31 -6.180875e-02  0.0510473909  0.022427030
## 2021-01-29 -5.720407e-02 -0.0573124878  0.006030179
## 2021-02-26 -5.310761e-02  0.0108991970  0.195373420
## 2021-03-31 -1.607435e-02 -0.0141220616  0.014184543
## 2021-04-30  8.903350e-02 -0.0020338080  0.075615931
## 2021-05-28 -3.688141e-02  0.0305598762 -0.043630240
## 2021-06-30  1.217604e-01  0.1240974899 -0.026044511
## 2021-07-30  9.207433e-02  0.0809136943 -0.058204247
## 2021-08-31  0.000000e+00 -0.0150255737  0.135384644
## 2021-09-30  1.125659e-02 -0.1260498377 -0.135384644
## 2021-10-29  1.410610e-01  0.1414101125  0.074760005
## 2021-11-30 -2.520723e-02  0.0115890355  0.061123031
## 2021-12-31 -1.491421e-01 -0.0135064168 -0.106634582
## 2022-01-31 -1.594356e-01 -0.1183306076 -0.120628053
## 2022-02-28 -4.228872e-02 -0.0809942181 -0.022771361
## 2022-03-31  1.323938e-01 -0.0124014782 -0.004488606
## 2022-04-29 -2.945232e-02 -0.0760993402 -0.092166084
## 2022-05-31 -1.919610e-01 -0.0480486173 -0.380411596
## 2022-06-30 -7.107189e-02 -0.1484560401 -0.246612676
## 2022-07-29  1.301740e-01  0.1173045103  0.085911426
## 2022-08-31 -3.456703e-02 -0.0765608361 -0.084593004
## 2022-09-30 -7.043217e-02 -0.2445217747 -0.241761124
## 2022-10-31  1.629624e-01  0.1088672398  0.095920107
## 2022-11-30  1.448074e-01  0.1685056503  0.284628674
## 2022-12-30 -1.714789e-01  0.0676659366  0.022676687
## 2023-01-31 -4.305100e-02  0.0845228122  0.200466799
## 2023-02-28  7.531549e-03 -0.0694250361 -0.214011011
## 2023-03-31  1.636874e-01  0.0347433234 -0.031162413
## 2023-04-28  4.231129e-02  0.0327266577 -0.059160252
## 2023-05-31 -1.350629e-01 -0.1855463631 -0.200394345
## 2023-06-30  1.312920e-01  0.0506911343  0.019564223
## 2023-07-31  7.925387e-05  0.0001810283  0.100580111
## 2023-08-31  7.186256e-03 -0.0818938012 -0.074108002
## 2023-09-29  1.134488e-02 -0.0583950870 -0.076902950
## 2023-10-31  2.020381e-02  0.0721113527  0.007806396
## 2023-11-30  1.270808e-01  0.0704384142  0.175037452
## 2023-12-29  1.348259e-01 -0.0121757339  0.086249621
## 2024-01-31 -1.192363e-01 -0.0670408903 -0.120781571
## 2024-02-29  2.882129e-02  0.0233633648  0.143280990
## 2024-03-28 -1.787099e-01 -0.0970691260 -0.179048246
## 2024-04-30 -8.004268e-02 -0.0184713554 -0.090838385
## 2024-05-31 -1.447982e-01  0.0297923709  0.065305107
## 2024-06-28 -4.353134e-02 -0.2280934091 -0.063772504
## 2024-07-31 -1.439253e-01 -0.0067896588  0.039043961
## 2024-08-30  3.126622e-03  0.1070688666  0.094104483
## 2024-09-30  4.476843e-02  0.0636339983  0.113902967
## 2024-10-31  9.334832e-02 -0.1363798119 -0.056595614
## 2024-11-29  7.362354e-02  0.0210400330  0.104474087
## 2024-12-30  1.803913e-01 -0.0486306069 -0.173919168
calculate_component_contribution <- function(.data, w) { covariance_matrix <- cov(.data)

# Standard deviation of portfolio
# Summarizes how much each asset's returns vary with those of other assets within the portfolio into a single number

sd_portfolio <- sqrt(t(w) %*% covariance_matrix %*% w)


# Component contribution
# Similar to the formula for sd_portfolio
# Mathematical trick to summarize the same, sd_portfolio, by asset instead of a single number
component_contribution <- (t(w) %*% covariance_matrix * w) / sd_portfolio[1,1]


rowSums(component_contribution)

# Component contribution in percentage
component_percentages <- (component_contribution / sd_portfolio[1,1]) %>%
    round(3) %>%
    as_tibble()

return (component_percentages)
    
}

asset_returns_wide_tbl %>% calculate_component_contribution (w = c(.45, .35, .2))
## # A tibble: 1 × 3
##    LULU   NKE    UA
##   <dbl> <dbl> <dbl>
## 1 0.467  0.29 0.243

5 Visualizing Component Contribution

Column Chart of Component Contribution and Weight

plot_data <- asset_returns_wide_tbl %>%
    calculate_component_contribution (w = c(.45, .35, .2)) %>%
    
    # Transform to long form
    pivot_longer(cols = everything(), names_to = "Asset", values_to = "Contribution") %>%
    
    #Add weights
    add_column(weight = c( .45, .35, .2)) %>%
    
    # Transform to long
    pivot_longer(cols = c(Contribution, weight), names_to = "type", values_to = "value")


plot_data %>%
    ggplot(aes(x = Asset, y = value, fill = type)) +
    geom_col(position = "dodge") +
    scale_y_continuous(labels = scales::percent_format(accuracy = 1)) +
    scale_fill_tq() +
    theme(plot.title = element_text(hjust = 0.5)) +
    theme_tq() +
    labs(title = "Percent Contribution to Portfolio Volatility and Weight", y = "Percent",
         x = NULL)

6 Rolling Component Contribution