[Highfrequency-commits] r114 - pkg/highfrequency/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Nov 25 09:04:31 CET 2014
Author: kboudt
Date: 2014-11-25 09:04:31 +0100 (Tue, 25 Nov 2014)
New Revision: 114
Modified:
pkg/highfrequency/R/highfrequencyGSOC.R
pkg/highfrequency/R/quantmod_patch.R
pkg/highfrequency/R/realized.R
Log:
added timeDate:: etc where needed
Modified: pkg/highfrequency/R/highfrequencyGSOC.R
===================================================================
--- pkg/highfrequency/R/highfrequencyGSOC.R 2014-09-15 22:35:20 UTC (rev 113)
+++ pkg/highfrequency/R/highfrequencyGSOC.R 2014-11-25 08:04:31 UTC (rev 114)
@@ -1448,7 +1448,7 @@
# compute the asymptotic covariance matrix of splittedparamsvector
- mH = hessian (.heavy_likelihood_ll, x= splittedparams, data=data, p=p, q=q, backcast=backcast, LB=LB, UB=UB, compconst=compconst)
+ mH = numDeriv::hessian(.heavy_likelihood_ll, x= splittedparams, data=data, p=p, q=q, backcast=backcast, LB=LB, UB=UB, compconst=compconst)
T = nrow(data)
nm = length(paramsvector)
@@ -1464,7 +1464,7 @@
## Define It
# jacobian will be T x length of theta
- m = jacobian(.heavy_likelihood_lls, x = splittedparams, data=data, p=p, q=q, backcast=backcast, LB=LB, UB=UB, compconst=compconst) # returns a vector?
+ m = numDeriv::jacobian(.heavy_likelihood_lls, x = splittedparams, data=data, p=p, q=q, backcast=backcast, LB=LB, UB=UB, compconst=compconst) # returns a vector?
It = cov(m)
}else{
@@ -1541,11 +1541,11 @@
require(sandwich);
fm = lm(m ~ 0);
- It = try(vcovHAC(fm))
+ It = try(sandwich::vcovHAC(fm))
if(class(It) == "try-error")
{
- print("HAC estimator is in error. It is replaced by non HAC estimator.")
+ print("HAC estimator reports an error. It is replaced by non HAC estimator.")
It = cov(m)
}
}
@@ -1558,7 +1558,7 @@
if( class(invJ) == "try-error"){
require("MASS")
print("-1*Hessian is not invertible - generalized inverse is used")
- invJ = ginv(Jt)
+ invJ = MASS::ginv(Jt)
}
Modified: pkg/highfrequency/R/quantmod_patch.R
===================================================================
--- pkg/highfrequency/R/quantmod_patch.R 2014-09-15 22:35:20 UTC (rev 113)
+++ pkg/highfrequency/R/quantmod_patch.R 2014-11-25 08:04:31 UTC (rev 114)
@@ -1,334 +1,399 @@
-###############################################################################
-# Utility functions for handling price data
-###############################################################################
-
-#' get price column(s) from a timeseries
-#'
-#' Will attempt to locate price column(s) from a time series with rational defaults.
-#'
-#' May be subset by symbol and preference.
-#' \code{prefer} Preference will be for any commonly used financial time series price description,
-#' e.g. 'trade', 'close', 'bid', 'ask' with specific tests and matching for types and column names
-#' currently supported in R, but a default grep match will be performed if one of the supported types doesn't match.
-#'
-#' @param x A data object with columns containing data to be extracted
-#' @param symbol text string containing the symbol to extract
-#' @param prefer preference for any particular type of price, see Details
-#' @param \dots any other passthrough parameters
-#' @export
-getPrice <- function (x, symbol=NULL, prefer=NULL,...)
-{
- # first subset on symbol, if present
- if(!is.null(symbol)){
- loc<-grep(symbol, colnames(x))
- if (!identical(loc, integer(0))) {
- x<-x[,loc]
- } else {
- stop(paste("subscript out of bounds: no column name containing",symbol))
- }
- }
- if(is.null(prefer)){
- # default to trying Price, then Trade, then Close
- if(has.Price(x)) prefer='price'
- else if(has.Trade(x)) prefer='trade'
- else if(has.Cl(x)) prefer='close'
- else stop("subscript out of bounds, no price was discernible from the data")
- }
- if(!is.null(prefer)){
- loc <- NULL
- switch(prefer,
- Op =, open =, Open = { loc <- has.Op(x,which=TRUE) },
- Hi =, high =, High = { loc <- has.Hi(x,which=TRUE) },
- Lo =, low =, Low = { loc <- has.Lo(x,which=TRUE) },
- Cl =, close =, Close = { loc <- has.Cl(x,which=TRUE) },
- Bid =, bid = { loc <- has.Bid(x,which=TRUE) },
- Ask =, ask =, Offer =, offer = { loc <- has.Ask(x,which=TRUE) },
- Mid =, mid =, Midpoint =, midpoint = { loc <- has.Mid(x,which=TRUE) },
- Trade =, trade = { loc <- has.Trade(x,which=TRUE) },
- Price =, price = { loc <- has.Price(x,which=TRUE) },
-{loc <- grep(prefer,colnames(x))}
- )
- if (!identical(loc, integer(0))) return(x[, loc])
- else stop("subscript out of bounds, no price was discernible from the data")
- }
-}
-
-#' @export
-is.BBO <- function (x)
-{
- if (all(has.Bid(x), has.Ask(x))) {
- TRUE
- }
- else FALSE
-}
-
-#' @export
-is.TBBO <- function (x)
-{
- if (all(has.Trade(x),has.Qty(x),has.Bid(x), has.Ask(x))) {
- TRUE
- }
- else FALSE
-}
-
-#' @export
-is.BAM <- function(x) {
- if (all(has.Bid(x), has.Ask(x), has.Mid(x))) {
- TRUE
- }
- else FALSE
-}
-
-#' @export
-is.BATM <- function(x) {
- if (all(has.Bid(x), has.Ask(x), has.Trade(x), has.Mid(x))) {
- TRUE
- }
- else FALSE
-}
-
-#' @export
-has.Bid <- function(x, which = FALSE)
-{
- colAttr <- attr(x, "Bid")
- if(!is.null(colAttr))
- return(if(which) colAttr else TRUE)
- #first try with "price" for data that has both bid.size and bid.price
- loc <- grep("bid.*price", colnames(x), ignore.case=TRUE)
- if (identical(loc, integer(0))) #If no column named bid.price
- loc <- grep("bid", colnames(x), ignore.case=TRUE) #look for bid
- if (!identical(loc, integer(0))) {
- return(if(which) loc else TRUE)
- } else FALSE
-}
-
-#' @export
-has.BidSize <- function(x, which = FALSE)
-{
- colAttr <- attr(x, "BidSize")
- if(!is.null(colAttr))
- return(if(which) colAttr else TRUE)
-
- loc <- grep("bid.*(size|qty|quantity)", colnames(x), ignore.case=TRUE)
- if (!identical(loc, integer(0))) {
- return(if(which) loc else TRUE)
- }
- loc <- grep("(bidsize|bidsiz)", colnames(x), ignore.case=TRUE)
- if (!identical(loc, integer(0))) {
- return(if(which) loc else TRUE)
- }
- else FALSE
-}
-
-#' @export
-has.Ask <- function(x, which = FALSE)
-{
- colAttr <- attr(x, "Ask") #case sensitive; doesn't work for SYMBOL.Ask :-(
- if(!is.null(colAttr))
- return(if(which) colAttr else TRUE)
- #first try with "price" for data that has both ask.size and ask.price
- loc <- grep("(ask|offer).*price", colnames(x), ignore.case=TRUE)
- if (identical(loc, integer(0))) #if that failed, try to find just "ask|offer"
- loc <- grep("(ask|offer|ofr)", colnames(x), ignore.case=TRUE)
- if (!identical(loc, integer(0))) {
- return(if(which) loc else TRUE)
- } else FALSE
-}
-
-#' @export
-has.AskSize <- function(x, which = FALSE)
-{
- colAttr <- attr(x, "AskSize")
- if(!is.null(colAttr))
- return(if(which) colAttr else TRUE)
-
- loc <- grep("(ask|offer).*(size|qty|quantity)", colnames(x), ignore.case=TRUE)
- if (!identical(loc, integer(0))) {
- return(if(which) loc else TRUE)
- }
- loc <- grep("(ofrsize|ofrsiz|offersize|offersiz)", colnames(x), ignore.case=TRUE)
- if (!identical(loc, integer(0))) {
- return(if(which) loc else TRUE)
- }
- else FALSE
-}
-
-#' @export
-has.Price <- function(x, which = FALSE)
-{
- colAttr <- attr(x, "Price")
- if(!is.null(colAttr))
- return(if(which) colAttr else TRUE)
-
- locBidAsk <- c(has.Bid(x, which=TRUE),has.Ask(x, which=TRUE))
- loc <- grep("price", colnames(x), ignore.case=TRUE)
- loc <- loc[!(loc %in% locBidAsk)]
- if (!identical(loc, integer(0))) {
- return(if(which) loc else TRUE)
- } else FALSE
-}
-
-#' @export
-has.Trade <- function(x, which = FALSE)
-{
- colAttr <- attr(x, "Trade")
- if(!is.null(colAttr))
- return(if(which) colAttr else TRUE)
-
- loc <- grep("trade", colnames(x), ignore.case=TRUE)
- if (!identical(loc, integer(0))) {
- return(if(which) loc else TRUE)
- } else FALSE
-}
-
-has.Mid <- function(x, which=FALSE) {
- colAttr <- attr(x, "Mid")
- if(!is.null(colAttr))
- return(if(which) colAttr else TRUE)
-
- loc <- grep("Mid", colnames(x), ignore.case = TRUE)
- if (!identical(loc, integer(0)))
- return(ifelse(which, loc, TRUE))
- ifelse(which, loc, FALSE)
-}
-
-has.Chg <- function(x, which=FALSE) {
- colAttr <- attr(x, "Chg")
- if(!is.null(colAttr))
- return(if(which) colAttr else TRUE)
- loc <- grep("(chg|change)", colnames(x), ignore.case=TRUE)
- if (!identical(loc, integer(0)))
- return(ifelse(which, loc, TRUE))
- ifelse(which, loc, FALSE)
-}
-
-#has.Un <- function(x, which=FALSE) {
-# loc <- grep("Unadj", colnames(x), ignore.case = TRUE)
-# if (!identical(loc, integer(0)))
-# return(ifelse(which, loc, TRUE))
-# ifelse(which, loc, FALSE)
-#}
-
-
-
-#' check for Trade, Bid, and Ask/Offer (BBO/TBBO), Quantity, and Price data
-#'
-#' A set of functions to check for appropriate TBBO/BBO and price column
-#' names within a data object, as well as the availability and
-#' position of those columns.
-#' @param x data object
-#' @param which disply position of match
-#' @aliases
-#' has.Trade
-#' has.Ask
-#' has.AskSize
-#' has.Bid
-#' has.BidSize
-#' has.Price
-#' is.BBO
-#' is.TBBO
-#' @export
-
-has.Qty <- function(x, which = FALSE)
-{
- colAttr <- attr(x, "Qty")
- if(!is.null(colAttr))
- return(if(which) colAttr else TRUE)
-
- locBidAsk <- c(has.Bid(x, which=TRUE),has.Ask(x, which=TRUE))
- loc <- grep("qty", colnames(x), ignore.case=TRUE)
- loc <- loc[!(loc %in% locBidAsk)]
- if (!identical(loc, integer(0))) {
- return(if(which) loc else TRUE)
- } else FALSE
-}
-
-# Column setting functions
-set.AllColumns <- function(x) {
- cols <- c("Op","Hi","Lo","Cl","Vo","Ad","Price","Trade","Qty",
- "Bid","BidSize","Ask","AskSize","Mid","Chg")
- for(col in cols) {
- try(x <- do.call(paste("set",col,sep="."), list(x)), silent=TRUE )
- }
- return(x)
-}
-
-set.Chg <- function(x, error=TRUE) {
- if(has.Chg(x))
- attr(x,"Chg") <- has.Chg(x, which=TRUE)
- return(x)
-}
-
-set.Mid <- function(x, error=TRUE) {
- if(has.Mid(x))
- attr(x,"Mid") <- has.Mid(x, which=TRUE)
- return(x)
-}
-
-set.Ad <- function(x, error=TRUE) {
- if(has.Ad(x))
- attr(x,"Ad") <- has.Ad(x, which=TRUE)
- return(x)
-}
-
-
-set.Bid <- function(x, error=TRUE) {
- if(has.Bid(x))
- attr(x,"Bid") <- has.Bid(x, which=TRUE)
- return(x)
-}
-set.BidSize <- function(x, error=TRUE) {
- if(has.BidSize(x))
- attr(x,"BidSize") <- has.BidSize(x, which=TRUE)
- return(x)
-}
-set.Hi <- function(x, error=TRUE) {
- if(has.Hi(x))
- attr(x,"Hi") <- has.Hi(x, which=TRUE)
- return(x)
-}
-set.Lo <- function(x, error=TRUE) {
- if(has.Lo(x))
- attr(x,"Lo") <- has.Lo(x, which=TRUE)
- return(x)
-}
-set.Op <- function(x, error=TRUE) {
- if(has.Op(x))
- attr(x,"Op") <- has.Op(x, which=TRUE)
- return(x)
-}
-set.Qty <- function(x, error=TRUE) {
- if(has.Qty(x))
- attr(x,"Qty") <- has.Qty(x, which=TRUE)
- return(x)
-}
-set.Vo <- function(x, error=TRUE) {
- if(has.Vo(x))
- attr(x,"Vo") <- has.Vo(x, which=TRUE)
- return(x)
-}
-set.Ask <- function(x, error=TRUE) {
- if(has.Ask(x))
- attr(x,"Ask") <- has.Ask(x, which=TRUE)
- return(x)
-}
-set.AskSize <- function(x, error=TRUE) {
- if(has.AskSize(x))
- attr(x,"AskSize") <- has.AskSize(x, which=TRUE)
- return(x)
-}
-set.Cl <- function(x, error=TRUE) {
- if(has.Cl(x))
- attr(x,"Cl") <- has.Cl(x, which=TRUE)
- return(x)
-}
-set.Price <- function(x, error=TRUE) {
- if(has.Price(x))
- attr(x,"Price") <- has.Price(x, which=TRUE)
- return(x)
-}
-set.Trade <- function(x, error=TRUE) {
- if(has.Trade(x))
- attr(x,"Trade") <- has.Trade(x, which=TRUE)
- return(x)
-}
+###############################################################################
+# Utility functions for handling price data
+###############################################################################
+
+#' get price column(s) from a timeseries
+#'
+#' Will attempt to locate price column(s) from a time series with rational defaults.
+#'
+#' May be subset by symbol and preference.
+#' \code{prefer} Preference will be for any commonly used financial time series price description,
+#' e.g. 'trade', 'close', 'bid', 'ask' with specific tests and matching for types and column names
+#' currently supported in R, but a default grep match will be performed if one of the supported types doesn't match.
+#'
+#' @param x A data object with columns containing data to be extracted
+#' @param symbol text string containing the symbol to extract
+#' @param prefer preference for any particular type of price, see Details
+#' @param \dots any other passthrough parameters
+#' @export
+getPrice <- function (x, symbol=NULL, prefer=NULL,...)
+{
+ # first subset on symbol, if present
+ if(!is.null(symbol)){
+ loc<-grep(symbol, colnames(x))
+ if (!identical(loc, integer(0))) {
+ x<-x[,loc]
+ } else {
+ stop(paste("subscript out of bounds: no column name containing",symbol))
+ }
+ }
+ if(is.null(prefer)){
+ # default to trying Price, then Trade, then Close
+ if(has.Price(x)) prefer='price'
+ else if(has.Trade(x)) prefer='trade'
+ else if(has.Cl(x)) prefer='close'
+ else stop("subscript out of bounds, no price was discernible from the data")
+ }
+ if(!is.null(prefer)){
+ loc <- NULL
+ switch(prefer,
+ Op =, open =, Open = { loc <- has.Op(x,which=TRUE) },
+ Hi =, high =, High = { loc <- has.Hi(x,which=TRUE) },
+ Lo =, low =, Low = { loc <- has.Lo(x,which=TRUE) },
+ Cl =, close =, Close = { loc <- has.Cl(x,which=TRUE) },
+ Bid =, bid = { loc <- has.Bid(x,which=TRUE) },
+ Ask =, ask =, Offer =, offer = { loc <- has.Ask(x,which=TRUE) },
+ Mid =, mid =, Midpoint =, midpoint = { loc <- has.Mid(x,which=TRUE) },
+ Trade =, trade = { loc <- has.Trade(x,which=TRUE) },
+ Price =, price = { loc <- has.Price(x,which=TRUE) },
+{loc <- grep(prefer,colnames(x))}
+ )
+ if (!identical(loc, integer(0))) return(x[, loc])
+ else stop("subscript out of bounds, no price was discernible from the data")
+ }
+}
+
+#' @export
+is.BBO <- function (x)
+{
+ if (all(has.Bid(x), has.Ask(x))) {
+ TRUE
+ }
+ else FALSE
+}
+
+#' @export
+is.TBBO <- function (x)
+{
+ if (all(has.Trade(x),has.Qty(x),has.Bid(x), has.Ask(x))) {
+ TRUE
+ }
+ else FALSE
+}
+
+#' @export
+is.BAM <- function(x) {
+ if (all(has.Bid(x), has.Ask(x), has.Mid(x))) {
+ TRUE
+ }
+ else FALSE
+}
+
+#' @export
+is.BATM <- function(x) {
+ if (all(has.Bid(x), has.Ask(x), has.Trade(x), has.Mid(x))) {
+ TRUE
+ }
+ else FALSE
+}
+
+#' @export
+has.Bid <- function(x, which = FALSE)
+{
+ colAttr <- attr(x, "Bid")
+ if(!is.null(colAttr))
+ return(if(which) colAttr else TRUE)
+ #first try with "price" for data that has both bid.size and bid.price
+ loc <- grep("bid.*price", colnames(x), ignore.case=TRUE)
+ if (identical(loc, integer(0))) #If no column named bid.price
+ loc <- grep("bid", colnames(x), ignore.case=TRUE) #look for bid
+ if (!identical(loc, integer(0))) {
+ return(if(which) loc else TRUE)
+ } else FALSE
+}
+
+#' @export
+has.BidSize <- function(x, which = FALSE)
+{
+ colAttr <- attr(x, "BidSize")
+ if(!is.null(colAttr))
+ return(if(which) colAttr else TRUE)
+
+ loc <- grep("bid.*(size|qty|quantity)", colnames(x), ignore.case=TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if(which) loc else TRUE)
+ }
+ loc <- grep("(bidsize|bidsiz)", colnames(x), ignore.case=TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if(which) loc else TRUE)
+ }
+ else FALSE
+}
+
+#' @export
+has.Ask <- function(x, which = FALSE)
+{
+ colAttr <- attr(x, "Ask") #case sensitive; doesn't work for SYMBOL.Ask :-(
+ if(!is.null(colAttr))
+ return(if(which) colAttr else TRUE)
+ #first try with "price" for data that has both ask.size and ask.price
+ loc <- grep("(ask|offer).*price", colnames(x), ignore.case=TRUE)
+ if (identical(loc, integer(0))) #if that failed, try to find just "ask|offer"
+ loc <- grep("(ask|offer|ofr)", colnames(x), ignore.case=TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if(which) loc else TRUE)
+ } else FALSE
+}
+
+#' @export
+has.AskSize <- function(x, which = FALSE)
+{
+ colAttr <- attr(x, "AskSize")
+ if(!is.null(colAttr))
+ return(if(which) colAttr else TRUE)
+
+ loc <- grep("(ask|offer).*(size|qty|quantity)", colnames(x), ignore.case=TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if(which) loc else TRUE)
+ }
+ loc <- grep("(ofrsize|ofrsiz|offersize|offersiz)", colnames(x), ignore.case=TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if(which) loc else TRUE)
+ }
+ else FALSE
+}
+
+#' @export
+has.Price <- function(x, which = FALSE)
+{
+ colAttr <- attr(x, "Price")
+ if(!is.null(colAttr))
+ return(if(which) colAttr else TRUE)
+
+ locBidAsk <- c(has.Bid(x, which=TRUE),has.Ask(x, which=TRUE))
+ loc <- grep("price", colnames(x), ignore.case=TRUE)
+ loc <- loc[!(loc %in% locBidAsk)]
+ if (!identical(loc, integer(0))) {
+ return(if(which) loc else TRUE)
+ } else FALSE
+}
+
+#' @export
+has.Trade <- function(x, which = FALSE)
+{
+ colAttr <- attr(x, "Trade")
+ if(!is.null(colAttr))
+ return(if(which) colAttr else TRUE)
+
+ loc <- grep("trade", colnames(x), ignore.case=TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if(which) loc else TRUE)
+ } else FALSE
+}
+
+has.Mid <- function(x, which=FALSE) {
+ colAttr <- attr(x, "Mid")
+ if(!is.null(colAttr))
+ return(if(which) colAttr else TRUE)
+
+ loc <- grep("Mid", colnames(x), ignore.case = TRUE)
+ if (!identical(loc, integer(0)))
+ return(ifelse(which, loc, TRUE))
+ ifelse(which, loc, FALSE)
+}
+
+has.Chg <- function(x, which=FALSE) {
+ colAttr <- attr(x, "Chg")
+ if(!is.null(colAttr))
+ return(if(which) colAttr else TRUE)
+ loc <- grep("(chg|change)", colnames(x), ignore.case=TRUE)
+ if (!identical(loc, integer(0)))
+ return(ifelse(which, loc, TRUE))
+ ifelse(which, loc, FALSE)
+}
+
+has.Cl <- function (x, which = FALSE){
+ colAttr <- attr(x, "Cl")
+ if (!is.null(colAttr))
+ return(if (which) colAttr else TRUE)
+ loc <- grep("Close", colnames(x), ignore.case = TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if (which) loc else TRUE)
+ }
+ else FALSE
+}
+
+has.Ad<-function (x, which = FALSE){
+ colAttr <- attr(x, "Ad")
+ if (!is.null(colAttr))
+ return(if (which) colAttr else TRUE)
+ loc <- grep("Adjusted", colnames(x), ignore.case = TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if (which) loc else TRUE)
+ }
+ else FALSE
+}
+
+has.Hi<-function (x, which = FALSE) {
+ colAttr <- attr(x, "Hi")
+ if (!is.null(colAttr))
+ return(if (which) colAttr else TRUE)
+ loc <- grep("High", colnames(x), ignore.case = TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if (which) loc else TRUE)
+ }
+ else FALSE
+}
+
+has.Lo<-function (x, which = FALSE){
+ colAttr <- attr(x, "Lo")
+ if (!is.null(colAttr))
+ return(if (which) colAttr else TRUE)
+ loc <- grep("Low", colnames(x), ignore.case = TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if (which) loc else TRUE)
+ }
+ else FALSE
+}
+
+has.Op<-function (x, which = FALSE) {
+ colAttr <- attr(x, "Op")
+ if (!is.null(colAttr))
+ return(if (which) colAttr else TRUE)
+ loc <- grep("Open", colnames(x), ignore.case = TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if (which) loc else TRUE)
+ }
+ else FALSE
+}
+
+has.Vo<-function (x, which = FALSE){
+ colAttr <- attr(x, "Vo")
+ if (!is.null(colAttr))
+ return(if (which) colAttr else TRUE)
+ loc <- grep("Volume", colnames(x), ignore.case = TRUE)
+ if (!identical(loc, integer(0))) {
+ return(if (which) loc else TRUE)
+ }
+ else FALSE
+}
+#has.Un <- function(x, which=FALSE) {
+# loc <- grep("Unadj", colnames(x), ignore.case = TRUE)
+# if (!identical(loc, integer(0)))
+# return(ifelse(which, loc, TRUE))
+# ifelse(which, loc, FALSE)
+#}
+
+
+
+#' check for Trade, Bid, and Ask/Offer (BBO/TBBO), Quantity, and Price data
+#'
+#' A set of functions to check for appropriate TBBO/BBO and price column
+#' names within a data object, as well as the availability and
+#' position of those columns.
+#' @param x data object
+#' @param which disply position of match
+#' @aliases
+#' has.Trade
+#' has.Ask
+#' has.AskSize
+#' has.Bid
+#' has.BidSize
+#' has.Price
+#' is.BBO
+#' is.TBBO
+#' @export
+
+has.Qty <- function(x, which = FALSE)
+{
+ colAttr <- attr(x, "Qty")
+ if(!is.null(colAttr))
+ return(if(which) colAttr else TRUE)
+
+ locBidAsk <- c(has.Bid(x, which=TRUE),has.Ask(x, which=TRUE))
+ loc <- grep("qty", colnames(x), ignore.case=TRUE)
+ loc <- loc[!(loc %in% locBidAsk)]
+ if (!identical(loc, integer(0))) {
+ return(if(which) loc else TRUE)
+ } else FALSE
+}
+
+# Column setting functions
+set.AllColumns <- function(x) {
+ cols <- c("Op","Hi","Lo","Cl","Vo","Ad","Price","Trade","Qty",
+ "Bid","BidSize","Ask","AskSize","Mid","Chg")
+ for(col in cols) {
+ try(x <- do.call(paste("set",col,sep="."), list(x)), silent=TRUE )
+ }
+ return(x)
+}
+
+set.Chg <- function(x, error=TRUE) {
+ if(has.Chg(x))
+ attr(x,"Chg") <- has.Chg(x, which=TRUE)
+ return(x)
+}
+
+set.Mid <- function(x, error=TRUE) {
+ if(has.Mid(x))
+ attr(x,"Mid") <- has.Mid(x, which=TRUE)
+ return(x)
+}
+
+set.Ad <- function(x, error=TRUE) {
+ if(has.Ad(x))
+ attr(x,"Ad") <- has.Ad(x, which=TRUE)
+ return(x)
+}
+
+
+set.Bid <- function(x, error=TRUE) {
+ if(has.Bid(x))
+ attr(x,"Bid") <- has.Bid(x, which=TRUE)
+ return(x)
+}
+set.BidSize <- function(x, error=TRUE) {
+ if(has.BidSize(x))
+ attr(x,"BidSize") <- has.BidSize(x, which=TRUE)
+ return(x)
+}
+set.Hi <- function(x, error=TRUE) {
+ if(has.Hi(x))
+ attr(x,"Hi") <- has.Hi(x, which=TRUE)
+ return(x)
+}
+set.Lo <- function(x, error=TRUE) {
+ if(has.Lo(x))
+ attr(x,"Lo") <- has.Lo(x, which=TRUE)
+ return(x)
+}
+set.Op <- function(x, error=TRUE) {
+ if(has.Op(x))
+ attr(x,"Op") <- has.Op(x, which=TRUE)
+ return(x)
+}
+set.Qty <- function(x, error=TRUE) {
+ if(has.Qty(x))
+ attr(x,"Qty") <- has.Qty(x, which=TRUE)
+ return(x)
+}
+set.Vo <- function(x, error=TRUE) {
+ if(has.Vo(x))
+ attr(x,"Vo") <- has.Vo(x, which=TRUE)
+ return(x)
+}
+set.Ask <- function(x, error=TRUE) {
+ if(has.Ask(x))
+ attr(x,"Ask") <- has.Ask(x, which=TRUE)
+ return(x)
+}
+set.AskSize <- function(x, error=TRUE) {
+ if(has.AskSize(x))
+ attr(x,"AskSize") <- has.AskSize(x, which=TRUE)
+ return(x)
+}
+set.Cl <- function(x, error=TRUE) {
+ if(has.Cl(x))
+ attr(x,"Cl") <- has.Cl(x, which=TRUE)
+ return(x)
+}
+set.Price <- function(x, error=TRUE) {
+ if(has.Price(x))
+ attr(x,"Price") <- has.Price(x, which=TRUE)
+ return(x)
+}
+set.Trade <- function(x, error=TRUE) {
+ if(has.Trade(x))
+ attr(x,"Trade") <- has.Trade(x, which=TRUE)
+ return(x)
+}
Modified: pkg/highfrequency/R/realized.R
===================================================================
--- pkg/highfrequency/R/realized.R 2014-09-15 22:35:20 UTC (rev 113)
+++ pkg/highfrequency/R/realized.R 2014-11-25 08:04:31 UTC (rev 114)
@@ -106,7 +106,7 @@
rdata = as.vector(rdata); seasadjR = as.vector(seasadjR);
intraT = length(rdata); N=1;
- MCDcov = as.vector(covMcd( rdata , use.correction = FALSE )$raw.cov)
+ MCDcov = as.vector(robustbase::covMcd( rdata , use.correction = FALSE )$raw.cov)
outlyingness = seasadjR^2/MCDcov
k = qchisq(p = 1 - alpha, df = N)
outlierindic = outlyingness > k
@@ -356,10 +356,10 @@
#
rho = 0.001
R = matrix( c(1,rho,rho,1) , ncol = 2 )
- int1 <- function(x) { dmvnorm(x,sigma=R) }
+ int1 <- function(x) { mvtnorm::dmvnorm(x,sigma=R) }
num = adaptIntegrate(int1, c(-3,-3), c(3,3), tol=1e-4)$integral
- int2 <- function(x) { x[1]*x[2]*dmvnorm(x,sigma=R) }
- denom = adaptIntegrate(int2, c(-3,-3), c(3,3), tol=1e-4)$integral
+ int2 <- function(x) { x[1]*x[2]*mvtnorm::dmvnorm(x,sigma=R) }
+ denom = cubature::adaptIntegrate(int2, c(-3,-3), c(3,3), tol=1e-4)$integral
c2 = rho*num/denom
return( (c1+c2)/2 )
}
@@ -2235,8 +2235,8 @@
if( onefile == FALSE ){
# Create trading dates:
- dates = timeSequence(from, to, format = "%Y-%m-%d", FinCenter = "GMT")
- dates = dates[isBizday(dates, holidays = holidayNYSE(1950:2030))];
+ dates = timeDate::timeSequence(from, to, format = "%Y-%m-%d", FinCenter = "GMT")
+ dates = dates[isBizday(dates, holidays = timeDate::holidayNYSE(1950:2030))];
# Create folder structure for saving:
if (dir) { dir.create(datadestination); for (i in 1:length(dates)) {dirname = paste(datadestination, "/", as.character(dates[i]), sep = ""); dir.create(dirname) } }
@@ -2339,8 +2339,9 @@
uniTAQload = function(ticker,from,to,trades=TRUE,quotes=FALSE,datasource=NULL,variables=NULL){
##Function to load the taq data from a certain stock
#From&to (both included) should be in the format "%Y-%m-%d" e.g."2008-11-30"
- dates = timeSequence(as.character(from),as.character(to), format = "%Y-%m-%d", FinCenter = "GMT")
- dates = dates[isBizday(dates, holidays = holidayNYSE(1960:2040))];
+ require("timeDate")
+ dates = timeDate::timeSequence(as.character(from),as.character(to), format = "%Y-%m-%d", FinCenter = "GMT")
+ dates = dates[timeDate::isBizday(dates, holidays = timeDate::holidayNYSE(1960:2040))];
if(trades){ tdata=NULL;
totaldata=NULL;
@@ -3099,12 +3100,12 @@
tradesCleanup = function(from,to,datasource,datadestination,ticker,exchanges,tdataraw=NULL,report=TRUE,selection="median",...){
-
+ require('timeDate')
nresult = rep(0, 5)
if(!is.list(exchanges)){ exchanges = as.list(exchanges)}
if (is.null(tdataraw)) {
- dates = timeSequence(from, to, format = "%Y-%m-d")
- dates = dates[isBizday(dates, holidays=holidayNYSE(1960:2040))]
+ dates = timeDate::timeSequence(from, to, format = "%Y-%m-d")
+ dates = dates[timeDate::isBizday(dates, holidays=timeDate::holidayNYSE(1960:2040))]
for (j in 1:length(dates)) {
datasourcex = paste(datasource, "/", dates[j], sep = "")
datadestinationx = paste(datadestination, "/", dates[j], sep = "")
More information about the Highfrequency-commits
mailing list