##tinychange
##' Convert factor variable to numeric
##'
##' Mostly because I dislike StringsAsFactors=FALSE
##' @title as.fnumeric
##' @param x a factor variable
##' @return a numeric variable
##' @author richie
##'@export
as.fnumeric <- function(x) {
as.numeric(as.character(x))
}
##' Misguided parsing function
##' See above
##' @title parse_quote
##' @param quote a quote object returned from the Stockfighter API
##' @return a matrix maybe?
##' @author richie
parse_quote <- function(quote) {
quotecontents <- sapply(quote, function(x) content(x))
numrows <- length(quotecontents)
numcols <- max(sapply(quotecontents, length))
resmat <- matrix(data=NA, nrow=numrows, ncol=numcols)
nameextractors <- tolower(names(quotecontents[[1]]))
for(i in 1:length(nameextractors)) {
fun <- get_component(component=nameextractors[i])
browser()
part <- fun(x=quotecontents)
resmat[1:length(part),i] <- part
}
resmat
}
##' repeat a function n times, storing the results in a list
##'
##' Should really generalise this to also allow for while loops, as it would simplify the monitor function greatly
##' @title repeat_call
##' @param times A positive integer equal to or greater than 1. The number of times the function is called.
##' @param call a function. Use of function(x) notation will be required for most functions
##' @param sleep number of seconds to sleep between iterations
##' @return a list containing the results of repeatedly evaluating call.
##' @author richie
##' @export
repeat_call <- function(times, call, sleep=0,print=FALSE ) {
reslist <- vector(mode="list", length=times)
fun <- match.fun(call)
for(i in 1:times) {
if(print) {
print(i)
}
reslist[[i]] <- fun()
if(sleep) {
Sys.sleep(sleep)
}
}
reslist
}
##' Convert a variable of factor class to numeric
##'
##' See above
##' @title as.fnumeric
##' @param x a factor variable that represents numbers
##' @return a numeric vector
##' @author richie
as.fnumeric <- function(x) {
as.numeric(as.character(x))
}
##TODO: check if this is used
response_to_df <- function(parsed_response) {
parsedmat <- do.call("rbind", parsed_response)
parsed.df <- sapply(as.data.frame(parsedmat), unlist)
parsed.df
}
##TODO:merge this with wss shell to create a monster!!!!(or at least reduce duplication)
get_tickertape <- function(account, venue) {
##sadface, Curl (and thus httr) doesn't support websockets
base_url_wss <- "wss://api.stockfighter.io/ob/api/ws/"
url <- paste(base_url_wss, account, "/venues/", venue, "/tickertape", sep="")
res <- httr::GET(url, add_headers("X-Starfighter-Authorization"=apikey))
}
##DONE: replace with lubridate::parse_date_time(t, "YmdhmOS") and call to set digits.secs=6
##TODO: use this function throughout code (figure out how to get Sys.time to work
##' An almost entirely unnecessary parsing function
##'
##' See above
##' @title parse_ts
##' @param order an object that has a ts type column
##' @param timestamp the column to convert (needs options(fractional.seconds=7+) to be useful
##' @return the object with the time in POSIXct with 6fractional seconds
##' @author richie
parse_ts <- function(order, timestamp) {
myts <- withr::with_options(c(digits.secs=6),
code=lubridate::parse_date_time(order[[timestamp]], "YmdhmOS6"), tz="UTC")
}
##TODO: change to as.data.frame method
##' Convert a list of quote objects to a dataframe
##'
##' Lists of quote objects are returned by the monitor function.
##' @title qlist_to_df
##' @param quotelist a list of quote objects
##' @return a dataframe containing the quote data, with NA for any value that was NULL in the response
##' @author richie
##' @export
qlist_to_df <- function(quotelist) {
stopifnot(class(quotelist[[1]])=="quote")
matrows <- length(quotelist)
matcols <- length(slotNames(quotelist[[1]]))
resmat <- matrix(data=NA, nrow=matrows, ncol=matcols)
for(i in 1:length(quotelist)) {
resmat[i,] <- as.vector.quote(quotelist[[i]])
}
resmat
colnames(resmat) <- slotNames(quotelist[[1]])
resdf <- as.data.frame(resmat)
## resdf <- dplyr::mutate(resdf, ok=as.logical(ok),
## bid=as.fnumeric(bid),
## bidSize=as.fnumeric(bidSize),
## askSize=as.fnumeric(askSize),
## bidDepth=as.fnumeric(bidDepth),
## last=as.fnumeric(last),
## lastSize=as.fnumeric(lastSize),
## last_trade=lubridate::ymd_hms(lastTrade),
## quote_time=lubridate::ymd_hms(quoteTime))
resdf
}
##TODO:merge or delete
##' An attempt at using the websocket endpoints.
##'
##' it appears that httr and curl don't support wss endpoints. I suspect that with some care, an upgrade request can be sent as per the spec (which allows for a HTTP response). This turned out to be true, I can get the server upgrade response, but I can't seem to parse it correctly (yet). This attempt was doomed, but I can call out to an external program and get the data, which is better than nothing
##' @title get_tickertape
##' @param account
##' @param venue
##' @param ...
##' @return nothing, as of yet
##' @author richie
get_tickertape <- function(account, venue, ...) {
base_ws<- "wss://api.stockfighter.io/ob/"
url <- paste(base_url, "ws/", account, "/venues/", venue, "/executions", sep="")
res <- httr::GET(url, add_headers(api_key=apikey,
"Upgrade"="websocket",
"Connection"="Upgrade",
"Sec-Websocket-Version"="13",
"Sec-Websocket-Key"="e23vsOnh1QGrwNI7ahsr7w==" ), ...)
return(res)
}
##TODO: probably delete
##' Monitor a stockfighter level
##'
##' Runs a while loop around a particular level
##' should probably generalise and re-factor this
##' @title monitor
##' @param venue
##' @param stock
##' @param level
##' @param name
##' @return nothing, called for side effects
##' @author richie
##' @export
monitor <- function(venue, stock, level=level, name=name) {
message("Stock is ", stock, " venue is ", venue, "\n")
start_time <- Sys.time()
ok <- TRUE
##this is total overkill, but hey
ordlist <- vector(mode="list", length=2e6)
quotelist <- vector(mode="list", length=2e5)
i <- 1
tryCatch({
while(ok) {
new_time <- Sys.time()
cl <- parallel::makeForkCluster(nnodes=6)
listvars <- rep(list(c(venue, stock)), 50)
orders <-
parallel::parLapply(cl,
listvars,
function (x)
get_orderbook(venue=x[1], stock=x[2]))
parallel::stopCluster(cl=cl)
quote <- get_quote(venue=venue, stock=stock)
ordlist[[i]] <- orders
quotelist[[i]] <- quote
cat("iteration at ", i, "\n")
i <- i + 1
ok <- content(orders[[length(orders)]])$ok
end_time <- Sys.time()
## cat("time taken ", end_time-new_time, "\n")
status <- change_instance(level, "")
browser()
parsed_status <- parse_response(status)
if(parsed_status$state != "open") {
break
}
}
}, finally = {
cat("reached finally", "\n")
## myorders <- get_all_orders(
file.ord <- paste("orderlist_", args[1], "_", args[2], ".rda", sep="")
file.quote <- paste("quotelist_", args[1], "_", args[2], ".rda", sep="")
save(ordlist, file=file.ord)
save(quotelist, file=file.quote)
change_instance(level=level, "stop")
end_time <- Sys.time()
cat("Total time taken, ", end_time-start_time, "\n")
})
ordlist
}
##TODO: generalise for level-status object
level_3_stats <- function(level) {
stat <- level_status(level=level)
sp <- stat %>% parse_response()
if(!is.null(sp$flash)) {
nums <- stringr::str_extract_all(unlist(stat[["flash"]]), "\\$[0-9]+")
cash <- nums[[1]][1]
NAV <- nums[[1]][2]
stats <- c(cash=cash, NAV=NAV)
stats
}
else {
return(NA)
}
}
##TODD: generalise all this to_df conversions
##' Take a series of calls to get_orderbook, and return the results as a df
##'
##' See above. Will document the fields here later
##' @title parse_orderlist
##' @param orderlist a list of calls to get_orderbook
##' @return a dataframe containing columns titled price, qty, isBuy, ok, venue, symbol, ymdhms (the timestamp) and milliseconds
##' @author richie
##' @export
parse_orderlist <- function(orderlist, parallel=TRUE, data.frame=TRUE) {
if(!parallel) {
odl2 <- orderlist[sapply(orderlist, function(x) !is.null(x))]
odl3 <- odl2[sapply(odl2, function (x) class(x)!="try-error")]
od.p <- lapply(odl3, parse_response)
odlok <- od.p[sapply(od.p, function (x) x$ok==TRUE)]
od.ob <- odlok %>% sapply(., orderbook)
if(data.frame) {
od.df <- lapply(od.ob, as.data.frame.orderbook)
res <- do.call("rbind", od.df)
return(res)
}
else {
res <- od.ob
return(res)
}
}
else {
odl2 <- orderlist[sapply(orderlist, function (x) !is.null(x))]
od.p <- lapply(odl2, function (x) lapply(x, parse_response))
odlok <- lapply(od.p, function (x) lapply(x, function (y) y$ok==TRUE))
od.ob <- odlok %>% lapply(., function (x) sapply(x, function (y) orderbook(y)))
od.df <- lapply(od.ob, function (x) lapply(x, function (y) as.data.frame.orderbook(y)))
res <- do.call("rbind", od.df)
}
res
}
##TODO: remove network access keep logic
##' Currently just gets bid and ask price
##'
##' Don't think this is at the right level of abstraction
##' @title get_price_and_qty
##' @param orderbook an orderbook object
##' @return a list containing bidprice and askprice
##' @author richie
##' @export
get_price_and_qty <- function(orderbook) {
bids.ord <- get_bids(orderbook)
asks.ord <- get_asks(orderbook)
bidna <- all(is.na(bids.ord))
askna <- all(is.na(asks.ord))
bothna <- all(bidna, askna)
venue <- venue(orderbook)
tick <- ticker(orderbook)
if (bothna) {
message("absolutely no market, monitoring again")
bids <- get_bid(venue, tick)
return(list(bids[1], bids[2], (bids[2] - bids [1])))
}
if(bidna) {
spread <- 20
message(paste("no curent bids, making market"))
askprice <- min(asks.ord$price)
bidprice <- ceiling(askprice - (spread / 4))
return(list(bidprice, askprice, spread))
}
if(askna) {
spread <- 20
bidprice <- max(bids.ord$price) + 1
askprice <- floor(bidprice + (spread / 4))
return(list(bidprice, askprice, spread))
}
message("got to calculating spread")
if(!bothna) {
spread <- min(asks.ord$price) - max(bids.ord$price)
myspread <- floor(spread * 0.8)
message(paste("spread is", myspread))
bidprice <- ceiling(max(bids.ord$price) + (myspread / 4))
askprice <- floor(min(asks.ord$price) - (myspread / 4))
return(list(bidprice, askprice, spread))
}
}
##TODO: fold into summary function
##' Honestly think I'll fold this into the summary function
##'
##'
##' @title bid_ask_ratio
##' @param ord
##' @return a list containing the bids, asks and the relative qty between them
##' @author richie
bid_ask_ratio <- function(ord) {
bidsum <- summary(ord, type="bids")
asksum <- summary(ord, type="asks")
bid_to_ask_qty <- max(bidsum$cum_qty) / max(asksum$cum_qty)
reslist <- list(b2a_qty=bid_to_ask_qty,
bids=bidsum, asks=asksum)
reslist
}
##' iterate over a list of venues, returning the stocks available at each
##'
##' As above
##' @title get_all_tickers
##' @param venues a vector of venues
##' @return a list of tickers available at each venue
##' @author richie
##'@export
get_all_tickers <- function(venues) {
myticks <- list()
for(i in 1:nrow(venues$venues)) {
ven <- venues$venues$venue
myticks[[i]] <- get_tickers(ven[i])
}
myticks
}
##TODO: handle how this interacts with the object structure
##' Returns f with timing added
##'
##' returns a function that will do the original work, and has an additional time component which gives the start and end times
##' @title timed
##' @param f a function
##' @param ... other arguments to be passed to f
##' @return a function with a signature of ... which passes arguments to f
##' @author richie
##' @export
timed <- function(f, ...) {
function(...) {
## dots <- as.list(substitute(list(...)))[-1L]
## args <- formals(f)
## names(dots) <- args
start <- withr::with_options(c(digits.secs=6), lubridate::now(tzone="UTC"))
res <- f(...)
end <- withr::with_options(c(digits.secs=6), lubridate::now(tzone="UTC"))
res <- list(time=data.frame(start=start, end=end), res)
}
}
##' get a timestamp with 6 fractional seconds in specified timezone
##'
##' Use to get local time inside functions requiring network calls. This function defaults to UTC
##' @title time
##' @return a timestamp object
##' @author richie
##'@export
get_time <- function(tz="UTC") {
instant <- withr::with_options(c(digits.secs=6), lubridate::now(tzone=tz))
}
##' Take the results of two calls to get_time, and return a dataframe containing the start and end of the interval
##'
##' Perhaps I should use the Interval class from lubridate?
##' @title make_timestamp
##' @param start the first instant
##' @param end the last instant
##' @return a data.frame containing start and end times
##' @author richie
##'@export
make_timestamp <- function(start, end) {
res <- data.frame(start=start, end=end)
}
## TODO: does this even work still?
##' shell out to wss program to get either executions or tickertape
##'
##' Need to integrate this properly at some point
##' @title wss_shell
##' @param level the current level
##' @param type either tickertape (quotes) or executions
##' @param location path for the wsclient executable
##' @return nothing, called for side effects
##' @author richie
##'@export
wss_shell <- function(level, type=c("tickertape", "executions"), location="./", ofile) {
account <- account(level)
venue <- venue(level)
stock <- ticker(level)
base_wss <- "wss://api.stockfighter.io/ob/api/ws/"
full_url <- paste0(base_wss, account, "/venues/", venue, "/", type, "/", "stocks/", stock)
print(full_url)
system(paste0(location, "wsclient ", full_url, "> ", ofile), wait=FALSE)
}
##' Run information functions in separate threads to ensure timing accuracy
##'
##' This function should give a window into market state at a consistent time
##' @title state_of_market
##' @param level a level
##' @param apikey an X-Starfighter-Authorization token
##' @return a list containing an orderbook, a quote object and details of current orders on this level
##' @author richie
##'@export
##'@importFrom future '%<-%'
state_of_market <- function(level, apikey, timed=TRUE) {
stopifnot(class(level)=="level")
account <- account(level)
venue <- venue(level)
stock <- ticker(level)
if(timed) {
quote <- future::future(timed_quote(venue, stock))
ord <- future::future(timed_orderbook(venue, stock))
myorders <- future::future(timed_orderlist(level, apikey))
status <- future::future(timed_status(level, apikey=apikey))
} else {
quote <- future::future(as_quote(venue, stock))
ord <- future::future(as_orderbook(venue, stock))
myorders <- future::future(as_orderlist(level, apikey))
status <- future::future(level_status(level, apikey=apikey))
}
res <- list(orderbook=future::value(ord),
quote=future::value(quote),
myorders=future::value(myorders),
status=future::value(status))
names(res) <- c("orderbook", "quote", "myorders", "level_status")
res
}
##TODO: use df conversion functions to handle this, index as a zoo class
##TODO: currently, this does nothing
##' Create or update an environment with market data
##'
##' This function uses global assignment and environments, so weird stuff is probably going to happen. (not right now it doesn't)
##' @title update_state
##' @param state an object returned by state_of_market
##' @return
##' @author richie
##' @export
update_state <- function(current, previous) {
if(is.null(previous)) {
orderb <- purrr::map(state, "orderbook")
## b2a <- bid_ask_ratio(orderb)
quote <- purrr::map(state, "quote")
myorders <- purrr::map(state, "quote")
status <- purrr::map(state, "level-status")
res <- list(orderb, quote, myorders, status)
}
}
##TODO: incorporate into update_state
##' Extract important fields from quote object
##'
##' To be used to build up market model
##' @title quote_stats
##' @param current current quote
##' @param previous previous output from quote stats.
##' @return a dataframe containing market information
##' @author richie
###@export
quote_stats <- function(current, previous) {
if(is.null(previous)) {
previous <- data.frame(bid = NA,ask = NA, last = NA,
ts = NA, start = NA, end = NA)
}
q <- current$quote[[2]]
bid <- q@bid
ask <- q@ask
last <- q@last
ts <- q@quoteTime
start_time <- current$quote$time[1]
end_time <- current$quote$time[2]
res <- data.frame(bid = bid, ask = ask, last = last,
ts = ts,
start = start_time,
end = end_time)
updatedf <- rbind(previous, res)
}
##' returns a dataframe containing all bids and asks
##'
##' Uses server time as index
##' @title orderbook_stats
##' @param current the new orderbook
##' @param previous the previous orderbook
##' @return an update
##' @author richie
##' @export
orderbook_stats <- function(current, previous) {
if (is.null(previous)) {
bids <- get_bids(current[[2]])
asks <- get_asks(current[[2]])
orderb <- rbind(bids, asks)
}
else {
bids <- get_bids(current[[2]])
asks <- get_asks(current[[2]])
curr <- rbind(bids, asks)
if(class(previous)=="orderbook") {
prevb <- get_bids(previous)
preva <- get_asks(previous)
prev <- rbind(prevb, preva)
}
else {
prev <- previous
}
orderb <- rbind(prev, curr)
}
}
##'@export
timed_orderbook <- timed(as_orderbook)
##'@export
timed_quote <- timed(as_quote)
##'@export
timed_orderlist <- timed(as_orderlist)
##'@export
timed_status <- timed(level_status)
full_orderbook <- function(orderbook) {
for(i in seq_along(orderbook)) {
if(i==1) {
ord <- orderbook_stats(orderbook[i], previous=NULL)
}
else {
ord <- orderbook_stats(orderbook[i], ord)
}
ord
}
ord
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.