PCA of SP500

sp500_frames.R

library(rARPACK)
library(dplyr)
library(tidyr)
library(RColorBrewer)
library(BatchGetSymbols)


# 4 years of data
first.date <- Sys.Date()-365*4
last.date <- Sys.Date()

# here are the tickers that we will analyze.
df.SP500 <- GetSP500Stocks()
tickers <- df.SP500$Tickers

# fetch the data.  Thanks yahoo <3
l.out <- BatchGetSymbols(tickers = tickers,
                         first.date = first.date,
                         last.date = last.date)

print(l.out$df.control)
print(l.out$df.tickers)

df = l.out$df.tickers %>% as_tibble()


stonks = df %>%
  select(ticker, ref.date, ret.adjusted.prices) %>%
  pivot_wider(names_from = ref.date,
              values_from = ret.adjusted.prices)

stonks = stonks %>% select(-ticker) %>% as.matrix
stonks[is.na(stonks)]=0
stonks = stonks[,-1]
s = stonks %>% scale %>% svds(k=1)

price = apply(stonks,1,cumsum) %>% t

# this is the actual PC
# plot(price[313,], col = "red", type = "l")
# -s$v %>% cumsum %>% lines()
# lines(-price[which.max(s$u),], col = "blue")
# hist(s$u)


coul <- brewer.pal(11, "RdBu")
approx = .5
bw = density(s$u)$bw
vals = seq(min(s$u)-4*bw, max(s$u)+bw, len = 400/approx)


for(i in 1:(2*(400/approx) - 1)){
  frame = i
  if(i>400/approx){
    i = 800/approx-i
  }
  #identify the images in a region around vals[i]
  w = exp(-(s$u-vals[i])^2/(bw*2)^2)
  png(file = paste("video_high_res/",frame,".png", sep=""),width = 1100, height = 850)
  par(mar = rep(0,4))
  plot(c(0,1006), c(min(price), max(price)), col = "white", xaxt = "n" , yaxt = "n",ylab = "", xlab = "",main = "")
  frame.proportion = i/(400/approx) *1006
  lines(frame.proportion*c(1,1), c(6,6.1))
  startHere = sum(w<.01)

  for(tick in order(w)){
    lines(price[tick,], col=grey(level = sqrt(1-w[tick]), alpha =sqrt(1-w[tick]) ))
  }
  colSums(diag(as.vector(w/sum(w)))%*%price) %>% lines(col = coul[10], lwd = 4)

  dev.off()
}

# To make the video, I go to quickTime -> File -> open image sequence.