###############################################################################
ComputePercentChange <- function(stock, plotit = FALSE) {
# Computes the value percent change in stock value for open and close times
# Args:
# stock: object of class stock
# plotit: whether to plot the stock values
if(plotit) {
p <- plot(stock)
on.exit(print(p))
}
n_obs <- nrow(stock$data)
change_data <- stock$data[c(1, n_obs), c("date", "open", "close")]
pct_change_open <- round(.ComputePercentageChange(change_data$open), 4)
pct_change_close <- round(.ComputePercentageChange(change_data$close), 4)
open_change <- structure(pct_change_open,
price_change = round(diff(change_data$open), 2))
close_change <- structure(pct_change_close,
price_change = round(diff(change_data$close), 2))
out <- structure(list(open = open_change,
close = close_change),
data = change_data)
return(out)
}
################################################################################
.ComputePercentageChange <- function(vector) {
if(length(vector) != 2) stop("Problem with input vector in .ComputePercentageChange")
first <- vector[1]
last <- vector[2]
absolute_change <- last - first
percent_change <- absolute_change / first * 100
}
################################################################################
ComputePriceChange <- function(stock) {
# Simple wrapper around PercentChange to get price change; returns no other information.
# Args:
# see PercentChange.
# Returns:
# length-1 numeric.
pct_change <- ComputePercentChange(stock, plotit = FALSE)
out <- list(open = attr(pct_change$open, "price_change"),
close = attr(pct_change$close, "price_change"))
return(out)
}
# StockChange -------------------------------------------------------------------------
.FindStockChangeCandidates <- function(price, pct_change, window = 1) {
# Determine the day on which a given percent change occurs within a given time window.
# Args:
# price: vector of stock prices under consideration
# pct_change: the desired percent change in stock price (positive or negative)
# window: the number of days within which the change occurs.
# Returns:
# logical vector of length length(price) where TRUE indicates a candidate for
# taking an action on the stock based on the pct_change criterion.
# Checks
if(pct_change == 0) stop("What are you even doing?")
if(window < 1) stop("That's not a real time window.")
# Take the appropriate lagged differences
diffs <- diff(price, lag = window)
# To get percent change we compare lagged differences to starting point
start_prices <- price[1L:(length(price) - window)]
price_changes <- diffs / start_prices * 100
# Padding for ineligible values at start of stock time window
pad <- rep(FALSE, window)
# Comparing price_changes to pct_change depends on sign of pct_change
compare <- if(pct_change < 0) `<` else `>`
# Return vector of dates on which desired pct_change is achieved within given window
c(pad, compare(price_changes, pct_change))
}
# PostChangeBuyDate --------------------------------------------------------------
.FindEarliestDateAmongConsecutives <- function(stock_change_candidates) {
# Calculate date of earliest stock change per run of TRUES coming from StockChangeCandidates.
# The purpose is to whittle down the candidates for action by keeping only the first candidate
# among many consecutive candidates. This means we don't keep buying a stock as it keeps falling
# day after day; we rather buy once and wait for an increase downstream.
first_n_minus_1_cand <- head(stock_change_candidates, n = length(stock_change_candidates) - 1L)
substraction_vector <- c(FALSE, first_n_minus_1_cand)
first_dates_are_greater_than_0 <- stock_change_candidates - substraction_vector
first_dates_post_change <- first_dates_are_greater_than_0 > 0
return(first_dates_post_change)
}
# PostChangeDateBuyDelay ----------------------------------------------------------
.AddWaitTimeBeforeAction <- function(action_date_candidates, delay = 0) {
# Produce time delay between stock price change and date of action equal in number
# of days to value 'delay'
trimmed_action_dates <- head(action_date_candidates,
n = length(action_date_candidates) - delay)
delay_vector <- rep(FALSE, times = delay)
action_date_vector <- c(delay_vector, trimmed_action_dates)
action_date_vector[length(action_date_vector)] <- FALSE # to prevent action on last day
return(action_date_vector)
}
# FindStockPercentChanges ----------------------------------------------------------
.FindStockPercentChanges <- function(current_price, other_prices) {
# From a given price and a vector of other prices, find the % change of other prices
# relative to current price.
(other_prices - current_price) / current_price * 100
}
.ProduceTrades <- function(price, actions, threshold) {
# From vector of action dates, produce true actions and reversions using trade threshold
# set up reversion vector
reversions <- rep(FALSE, times = length(price))
# Return if no actions taken
if(sum(actions) == 0) {
out <- list(actions = reversions,
reversions = reversions)
return(out)
}
# If actions taken, set up for a while-loop
.CompareFun <- if(threshold < 0) `<` else `>`
i <- which(actions)[1L]
while(TRUE) {
# Find ALL timepoints when threshold is crossed, INCLUDING backwards in time
pct_changes <- .FindStockPercentChanges(price[i], price)
all_candidates <- .CompareFun(pct_changes, threshold)
all_candidates_ix <- which(all_candidates)
# if there are reversion candidates after this action, find the correct one;
# otherwise, kill all future action candidates and revert on the last possible day
if(any(all_candidates_ix > i)) {
all_fwd_candidates_ix <- all_candidates_ix[which(all_candidates_ix > i)]
min_fwd_cand_ix <- min(all_fwd_candidates_ix)
actions[(i+1):min_fwd_cand_ix] <- FALSE
reversions[min_fwd_cand_ix] <- TRUE
} else {
actions[(i+1):length(actions)] <- FALSE
reversions[length(reversions)] <- TRUE
break()
}
# find next i
if(min_fwd_cand_ix < length(actions)-1L && any(actions[(min_fwd_cand_ix+1L):length(actions)])) {
current_actions <- which(actions)
i <- min(current_actions[current_actions > i])
} else {
break()
}
}
out <- list(actions = actions,
reversions = reversions)
return(out)
}
# CalculateStockDropReturn -----------------------------------------------------------
.CalculateStockDropReturn <- function(price, trades, budget, trade_fee, threshold) {
# Computes dollar return from the trade strategies given by actions and reversions
# Args:
# price: vector of stock prices under consideration
# trades: list output of .ProduceTrades()
# budget: the maximum dollar amount to invest at each buy
# trade_fee: the dollar fee for each trade
# threshold: the percent threshold that signals action; used to determine "buy" or "short"
action_prices <- price[trades$actions]
reversion_prices <- price[trades$reversions]
action_quantity <- StockQty(budget, action_prices)
action_dollars <- action_quantity * action_prices
reversion_dollars <- action_quantity * reversion_prices
n_trades_vector <- sapply(trades, sum)
n_trades <- sum(n_trades_vector)
if(threshold < 0) {
dollars_net <- sum(reversion_dollars - action_dollars) - n_trades * trade_fee
dollars_invested <- sum(action_dollars) + n_trades * trade_fee
} else {
dollars_net <- sum(action_dollars - reversion_dollars) - n_trades * trade_fee
dollars_invested <- sum(reversion_dollars) + n_trades * trade_fee
}
percent_return <- if(n_trades > 0) {
dollars_net / dollars_invested * 100
} else {
0
}
stock_drop_return <- list(net_return = round(dollars_net, 2L),
amt_spent = round(dollars_invested, 2L),
pct_return = round(percent_return, 2L),
amt_pledged = budget * n_trades / 2,
n_trades = n_trades)
return(stock_drop_return)
}
# BuyAndHoldSingle -----------------------------------------------------------------------
BuyAndHoldSingle <- function(price, budget, trade_fee = 9) {
# Compute earnings from buy-and-hold strategy over entire stock history provided.
# Use this as a benchmark to compare any trading strategy attempted.
if(budget > 0) {
buy_price <- price[1L]
sell_price <- price[length(price)]
buy_qty <- StockQty(budget, buy_price)
money_in <- buy_price * buy_qty + trade_fee * 2 # only two trades are ever made in this approach
money_out <- sell_price * buy_qty
net_cash <- money_out - money_in
pct_return <- net_cash / money_in * 100
out <- list(net_return = round(net_cash, 2),
amt_spent = round(money_in, 2),
pct_return = round(pct_return, 2))
} else {
out <- list(net_return = 0,
amt_spend = 0,
pct_return = 0)
}
return(out)
}
# StockDropAndRoll ---------------------------------------------------------------------
StockDropAndRoll <- function(stock, budget, pct_change, reversion_pct, search_window = 1,
action_delay = 0, trade_fee = 9, time = "open") {
# Performs all steps to compute return from stock change trading strategy
price <- stock$data[[time]]
change_candidates <- .FindStockChangeCandidates(price, pct_change, search_window)
post_change_dates <- .FindEarliestDateAmongConsecutives(change_candidates)
actions <- .AddWaitTimeBeforeAction(post_change_dates, action_delay)
trades <- .ProduceTrades(price, actions, reversion_pct)
stock_drop_returns <- .CalculateStockDropReturn(price, trades, budget, trade_fee, pct_change)
buy_and_hold_returns <- BuyAndHoldSingle(price,
budget = budget * stock_drop_returns$n_trades / 2,
trade_fee = trade_fee)
drop_list <- list(stock_drop_returns,
symbol = stock$symbol,
budget = budget,
pct_change_trigger = pct_change,
reversion_pct_trigger = reversion_pct,
search_window = search_window,
action_delay = action_delay,
trade_fee = trade_fee,
time = time,
pct_return_buy_and_hold = buy_and_hold_returns$pct_return,
points_over_buy_and_hold = stock_drop_returns$pct_return -
buy_and_hold_returns$pct_return,
stock$data[c("date", time)],
trades)
drop_return <- unlist(drop_list, recursive = FALSE)
names(drop_return)[grepl(time, names(drop_return))] <- "price"
out <- structure(drop_return, class = "drop_model")
return(out)
}
# print.drop_model -----------------------------------------------------------
print.drop_model <- function(x, ...) {
# Makes readable format for drop_model object
line1 <- paste0("Stock: ", x$symbol)
line2 <- paste0("Amount spent: ", x$amt_spent, 2)
line3 <- paste0("Net return: ", x$net_return, 2)
line4 <- paste0("Percent return: ", x$pct_return, 3)
line5 <- paste0("Points over buy-and-hold: ", round(x$points_over_buy_and_hold, 2))
cat(paste(line1, line2, line3, line4, line5, sep = "\n"))
}
# predict.drop_model --------------------------------------------------------
predict.drop_model <- function(object, newdata, ...) {
# Get return from test data based on parameters of drop_model object.
# Pass test stock data to argument "newdata".
out <- StockDropAndRoll(stock = newdata,
budget = object$budget,
pct_change = object$pct_change_trigger,
reversion_pct = object$reversion_pct_trigger,
search_window = object$search_window,
action_delay = object$action_delay,
trade_fee = object$trade_fee,
time = object$time)
}
# plot.drop_model -------------------------------------------------------------------
.ComputeRectDataDrop <- function(price, date, actions, reversions) {
# Creates rectangle coordinates for plot
# Args:
# price: vector of prices associated with actions and reversions vectors
# actions: logical vector indicating when to execute action
# reversions: logical vector indicating when to revert action
# Coordinates for rectangles
xmin <- date[actions]
xmax <- date[reversions]
ymin <- rep(min(price), times = length(xmin))
ymax <- rep(max(price), times = length(xmin))
# Data frame for plotting
data.frame(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax)
}
.MakePlotDataDrop <- function(drop_model) {
# Creates data frame for ggplot2
data.frame(date = drop_model$date,
price = drop_model$price)
}
plot.drop_model <- function(x, ...) {
# Plots stock timeline with highlighting rectangles in trading regions.
# Args:
# x: object of class drop_model
rect_df <- .ComputeRectDataDrop(x$price, x$date, x$actions, x$reversions)
plot_data <- .MakePlotDataDrop(x)
ggplot(NULL) +
geom_rect(data = rect_df,
aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax),
alpha = 0.3, fill = "skyblue") +
geom_line(data = plot_data, aes(x = date, y = price), lwd = 1.2) +
labs(x = "Date", y = "Price", title = "Trading Periods") +
theme_bw()
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.