R/pub02_dataGettingFuncs.R
In raphael210/QDataGet: Data getting functionns
Defines functions
tsInclude
tsLoad
tsRequire
rdate2ts
tsdate2r
ts.wss
memory.load
TS.sus_res
Documented in
memory.load
rdate2ts
tsdate2r
tsInclude
tsLoad
tsRequire
TS.sus_res
ts.wss
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx =====================
# ==================== Tinysoft related utility functions ====================
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx =====================
#' tsInclude
#'
#' Series of functions of connect/login Tinysoft server, and remote call funcions of Tinysoft.
#' @param funchar a charactor string of tinysoft script
#' @param pars a list of funchar's parametres
#' @param syspars a list of tinysoft system parametres.(including:StockID CurrentDate Cycle bRate RateDay Precision)
#' @return tsInclude: include and load the external dll;
#' @return tsRequre: test if tinysoft connected, if not, connect it.
#' @author ruifei.yin
#' @export
#' @examples
#' tsInclude()
#' tsConnect()
#' tsLogined()
#' tsRemoteExecute("return close();",list(StockID="SZ000002",CurrentDate=rdate2ts(as.Date("2014-11-11"))))
#' # use ldply/laply/llply to transform the result from list to comfortable form
#' ll <- tsRemoteExecute("return Array(('a':1,'b':4),('a':2,'b':5),('a':3,'b':6));")
#' plyr::ldply(ll,as.data.frame)
#' plyr::laply(ll,as.array)
#' plyr::llply(ll,unlist)
#' tsRemoteCallFunc("close",,list(StockID="SZ000002"))
#' tsRemoteCallFunc("rand",list(2,3))
#' tsDisconnect()
tsInclude <- function(os = R.Version()$arch){
source(paste(.libPaths()[1],"/QDataGet/tslr/tslr.R",sep = ""))
tsLoad(os)
}
#' @rdname tsInclude
#' @export
tsLoad <- function(os = R.Version()$arch){
libpath <- .libPaths()[1]
if(os == "i386"){
dyn.load(paste(libpath,"/QDataGet/tslr/i386/tslr.dll",sep = ""))
}else if(os == "x86_64"){
dyn.load(paste(libpath,"/QDataGet/tslr/x64/tslr.dll",sep = ""))
}
}
#' @export
#' @rdname tsInclude
tsRequire <- function(){
if(!exists("tsLogined")){
tsInclude()
}
if(!is.loaded("tslConnectServer")){
tsLoad()
}
if(tsLogined()==0){
tsConnect()
}
}
#' rdate2ts
#'
#' transform the R date to tinysoft date value
#' @param rdate a vector with \bold{Date} class
#' @param GAP.R2TS the constant of R to tinysoft date-transformating
#' @return a vector containing the tinysoft date value transformed from the R date
#' @seealso \code{\link{tsdate2r}}
#' @author Ruifei.Yin
#' @export
rdate2ts <- function(rdate, GAP.R2TS=25569){
tsdate <- rdate + GAP.R2TS
tsdate <- as.numeric(tsdate)
return(tsdate)
}
#' tsdate2r
#'
#' transform the tinysoft date value to R date
#' @param tsdate a vector containing the tinysoft date value
#' @param GAP.R2TS the constant of R to tinysoft date-transformating
#' @return a vector with \bold{Date} class, transformed from the tinysoft date value
#' @seealso \code{\link{rdate2ts}}
#' @author Ruifei.Yin
#' @export
tsdate2r <- function(tsdate, GAP.R2TS=25569){
rdate <- tsdate - GAP.R2TS
rdate <- as.Date(rdate,origin="1970-01-01")
return(rdate)
}
#' ts.wss
#'
#' realize the "stock-data-expert" functions in Tinysoft.Given the stocklist, get specific variables of the stocks from Tinysoft.
#' @param stocks a vector of stockID.
#' @param funchar expression to get variables from tinysoft,a character string, usually copyed from tinysoft "stock-data-expert". If you want to specify the rptDate by param \code{rptDate}, the expression should be converted simply by replaceing the specified reportdate in the stock-data-expert expression by \code{'Rdate'}. e.g. convert \code{Last12MData(20091231,46002)} to \code{Last12MData(Rdate,46002)}.
#' @param varname vector of charactor string
#' @param rptDate a specified rptDate, with class of Date. Could be missing when unnessasry. See examples for more detail.
#' @param Time a Date object, giving the pn_date() in tinysoft
#' @param Rate a integer,giving the type of rights adjustment, could be one of 0(no adjustment),1(geometric adjustment),2(simple adjustment),3
#' @param RateDay a integer,giving the base date of right adjustment,could be one of 0(the last trading day),-1(the IPO date),or a tinysoft date integer(eg. \code{rdate2ts(as.Date("2010-01-02"))})
#' @param adjust_yoy a logic. If TRUE, param \code{Time} will be set to \code{rptDate.deadline(rptDate)}, the financial index before(not including) \code{rptDate} will be adjusted, the financial index after \code{rptDate} will not be adjusted.
#' @return a dataframe,with cols:stockID,stockName,and the returned variables.
#' @note you can get different financial index by set param Time and param adjust_yoy.
#' If you set param \code{Time} to 1900-01-01, all the financial index returned will not be adjusted; If you set param \code{Time} to \code{Sys.Date()}, all the financial index returned will be adjusted; See example for detail.
#' @export
#' @family stockDataExpert functions
#' @examples
#' stocks <- c("EQ600011","EQ000631","EQ000004")
#' funchar1 <- '"eps",reportofall(9900000,20121231),
#' "zyywlrzzl",reportofall(9900601,20121231),
#' "yszk",report(44009,20121231),
#' "isFinanceCompany",IsFCompany_(),
#' "close",close(),
#' "rtn(%)(19890705,20120705)",StockZf(32694,41095),
#' "Ndayrtn(%)(N=10)",StockZf2(10),
#' "floatMV(20110926)",StockMarketValue(40812)'
#' re1 <- ts.wss(stocks,funchar1)
#'
#' # -- specify the rptDate
#' funchar2 <- '"eps",reportofall(9900000,Rdate),
#' "zyywlrzzl",reportofall(9900601,Rdate),
#' "yszk",report(44009,Rdate),
#' "isFinanceCompany",IsFCompany_(),
#' "close",close(),
#' "rtn(%)(19890705,20120705)",StockZf(32694,41095),
#' "Ndayrtn(%)(N=10)",StockZf2(10),
#' "floatMV(20110926)",StockMarketValue(40812)'
#' re2 <- ts.wss(stocks,funchar2,rptDate=as.Date('2012-12-31'))
#'
#' all.equal(re1,re2) # TRUE
#'
#' # -- getting financial index (adjust or not)
#' ts.wss("EQ000027",'"G_NP_Q",LastQuarterData(Rdate,9900604,0)',as.Date("2007-03-31"),Time=as.Date("1900-06-29")) # 31.8 (07_adj/06_adj-1)
#' ts.wss("EQ000027",'"G_NP_Q",LastQuarterData(Rdate,9900604,0)',as.Date("2007-03-31"),Time=Sys.Date()) # 229.16 (07_unadj/06_unadj-1)
#' ts.wss("EQ000027",'"G_NP_Q",LastQuarterData(Rdate,9900604,0)',as.Date("2007-03-31"),adjust_yoy=TRUE) # 49 (07_unadj/06_adj-1) This is the correct one!
ts.wss <- function(stocks,funchar,varname,rptDate,Time=Sys.Date(),Rate=1,RateDay=0,
adjust_yoy=FALSE){
stocks <- stockID2stockID(stocks,from="local",to="ts")
if(missing(rptDate)) {
rptDate <- 0
} else {
if(adjust_yoy){
Time <- rptDate.deadline(rptDate)
}
rptDate <- rdate2int(rptDate)
}
Time=rdate2ts(Time)
syspars <- list(CurrentDate=Time,bRate=Rate,RateDay=RateDay)
stocks.str <- paste(stocks,collapse=";")
str <- paste('Rdate:=',rptDate,';\n',
'return Query("","',
stocks.str,
'",True,"","stockID",DefaultStockID(),',
funchar,
');',
sep="")
tsRequire()
re <- tsRemoteExecute(str,syspars)
re <- plyr::ldply(re,as.data.frame)
re$stockID <- stockID2stockID(re$stockID,from="ts",to="local")
if(!missing(varname)){
re <- renameCol(re,colnames(re)[-1],varname)
}
return(re)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# ================== tradingday related =============
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' memory.load
#'
#' load frequently used data into memory, including \code{.tradingdays}, \code{.QT_sus_res}, ...
#' @param reload a logic. If reload the memory data?
#' @return return NULL, but load some data into memory.
#' @export
#' @author Ruifei.Yin
memory.load <- function(reload=FALSE){
if(!exists(".tradingdays") || reload){
if(reload){
message("[memory data reloading]")
} else {
message("[memory data loading]")
}
# -- the market trading days
message(" Loading '.tradingdays' ... ")
qr1 <- "select TradingDate from QT_TradingDay where SecuMarket=83 and IfTradingDay=1"
tradingdays <- queryAndClose.dbi(db.local("main"),qr1)[[1]]
.tradingdays <<- intdate2r(tradingdays)
con_qt <- db.local("qt")
con_main <- db.local("main")
# - QT_sus_res
message(" Loading '.QT_sus_res' ... ")
QT_sus_res <- dbReadTable(con_qt,"QT_sus_res")
QT_sus_res <- data.table::data.table(QT_sus_res,key = "stockID")
.QT_sus_res <<- QT_sus_res[is.na(res),res:=99990101
][,`:=`(sus=intdate2r(sus),res=intdate2r(res))
][,-("updateDate"),with=FALSE
]
# -- the market size data frame
message(" Loading '.marketsize' ... ")
.marketsize <<- dbReadTable(con_qt, "QT_Size")
.marketsize$date <<- intdate2r(.marketsize$date)
# - LC_ExgIndustry
message(" Loading '.LC_ExgIndustry' ... ")
LC_ExgIndustry <- dbReadTable(con_main,"LC_ExgIndustry")
LC_ExgIndustry <- data.table::data.table(LC_ExgIndustry,key = "stockID")
.LC_ExgIndustry <<- LC_ExgIndustry[is.na(OutDate),OutDate:=99990101
][,`:=`(InDate=intdate2r(InDate),OutDate=intdate2r(OutDate))]
dbDisconnect(con_qt)
dbDisconnect(con_main)
} else {
.QT_sus_res <- data.table::alloc.col(.QT_sus_res)
.LC_ExgIndustry <- data.table::alloc.col(.LC_ExgIndustry)
}
}
#' TS.sus_res
#'
#' get the suspension and resumption data
#' @return a data.frame with cols: "sus" and "res"
#' @export
#' @author Ruifei.yin
#' @examples
#' TS <- getTS(getRebDates(as.Date("2007-01-01"),as.Date("2016-01-01"),rebFreq = "week"),indexID = "EI000300")
#' microbenchmark::microbenchmark(re <- TS.sus_res(TS,datasrc="memory"),re1 <- TS.sus_res(TS,datasrc = "local"),times = 10) # 100 VS. 3000
TS.sus_res <- function(TS,datasrc="memory"){
TS_ <- TS[,c("date","stockID")]
if(datasrc == "memory"){
memory.load()
TS_ <- data.table::data.table(TS_)
re <- .QT_sus_res[TS_,.(date,stockID,x.sus,x.res),on=.(stockID,sus<=date,res>date)]
re <- renameCol(re,c("x.sus","x.res"),c("sus","res"))
re <- as.data.frame(re)
} else if(datasrc == "local"){
TS_$date <- rdate2int(TS_$date)
con <- db.local("qt")
qr <- paste(
"select date,a.stockID,sus,res
from temp_table as a left join QT_sus_res as b
on a.stockID=b.stockID and sus<=date and (res>date or res is null)" )
dbWriteTable(con,name="temp_table",value=TS_[,c("date","stockID")],row.names = FALSE,overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
re <- dplyr::mutate(re,date=intdate2r(date),sus=intdate2r(sus),res=intdate2r(res))
}
re <- merge.x(TS,re,by=c("date","stockID"),mult = "first")
return(re)
}
#' trday.get
#'
#' get the trading date series from begT to endT
#' @param begT a Date object.The default is as.Date("1990-12-19")
#' @param endT a Date object.The default is Sys.Date()
#' @param stockID a character string or null. If null, the market trading days, other wise the trading days of specific stock.
#' @return a vector of class Date
#' @export
#' @author Ruifei.yin
#' @examples
#' re <- trday.get()
#' re <- trday.get(as.Date("2012-01-01"),as.Date("2012-09-30"))
#' re <- trday.get(as.Date("2012-07-01"),as.Date("2013-03-30"),stockID="EQ000527")
#' system.time(replicate(100,ii <- trday.get(datasrc="local"))) # 14.09
#' system.time(replicate(100,ii <- trday.get(datasrc="memory"))) # 0.39
#' system.time(replicate(100,ii <- trday.get(datasrc="local",stockID="EQ000527"))) # 16.38
#' system.time(replicate(100,ii <- trday.get(datasrc="memory",stockID="EQ000527"))) # 1.25
trday.get <- function(begT=as.Date("1990-12-19"),endT=Sys.Date(),
stockID=NULL,
datasrc="memory"){
# get the market trading days
if(datasrc %in% c("quant","local")){
begT <- max(begT,as.Date("1990-12-19"))
begT <- rdate2int(begT)
endT <- rdate2int(endT)
qr <- paste("select TradingDate from QT_TradingDay where SecuMarket=83 and IfTradingDay=1 and TradingDate between ",begT,"and",endT)
if(datasrc=="quant"){
trday <- queryAndClose.odbc(db.quant(),qr)
} else if(datasrc=="local"){
trday <- queryAndClose.dbi(db.local("main"),qr)
}
re <- trday[[1]]
re <- intdate2r(re)
} else if (datasrc=="memory") {
memory.load()
begT <- max(begT,as.Date("1990-12-19"))
re <- get(".tradingdays")
re <- re[re >= begT & re <= endT]
}
# get the stock's trading days
if(!is.null(stockID)){
TS <- expand.grid(date=re, stockID=stockID)
sus_res <- TS.sus_res(TS,datasrc = datasrc)
isTradingday <- is.na(sus_res$sus)
re <- re[isTradingday]
}
re <- re[order(re)]
return(re)
}
#' trday.is
#'
#' Identify if the date is trading day or not
#' @param datelist a vector of class Date
#' @param stockID a character string or NULL If NULL, the market trading days, other wise the trading days of specific stock.
#' @return a logical vecter with elements TRUE or FALSE depending on whether its argument is an tradingday
#' @export
#' @author Ruifei.Yin
#' @examples
#' datelist <- seq(from=as.Date("2013-01-21"),to=as.Date("2013-01-30"),by="day")
#' trday.is(datelist)
#' trday.is(datelist,stockID="EQ000527")
#' trday.is(TS=TS)
trday.is <- function(datelist,stockID=NULL,TS,
drop=FALSE){
if(is.null(stockID) & missing(TS)){ # the market tradingday
mindt <- min(datelist)
maxdt <- max(datelist)
tradingday <- trday.get(begT=mindt,endT=maxdt,stockID=NULL)
re <- datelist %in% tradingday
return(re)
}
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
sus_res <- TS.sus_res(TS)
isTradingday <- trday.is(sus_res$date,stockID=NULL) & is.na(sus_res$sus)
if(drop){
re <- isTradingday
}else {
re <- cbind(TS,isTradingday)
}
return(re)
}
#' trday.nearest
#'
#' get the nearest tradingday.
#' @param datelist a vector of class Date
#' @param dir a integer. Indicating forward or backward to find, if \code{datelist} is not tradingday. -1 for backward, 1 for forward.
#' @param stockID a character string or null. If null, the market trading days, other wise the trading days of specific stock.
#' @return a vector of class Date, the value of which is the nearest tradingday before/after the \code{datelist} if \code{datelist} is not a tradingday, otherwise,the \code{datelist} itself.
#' @author Ruifei.Yin
#' @export
#' @examples
#' datelist <- as.Date(c("2012-07-21","2012-07-22","2012-07-23","2013-01-30"))
#' trday.nearest(datelist)
#' trday.nearest(datelist, dir = 1)
#' trday.nearest(datelist, dir = 1, stockID="EQ000527")
trday.nearest <- function(datelist, dir=-1L, stockID=NULL, TS,
drop=FALSE){
if(is.null(stockID) & missing(TS)){ # the market tradingday
tradingdays <- trday.get(endT=Sys.Date()+365, stockID=NULL)
if(dir == -1L){
re <- tradingdays[findInterval(datelist, tradingdays)]
} else if(dir == 1L){
re <- tradingdays[findInterval.rightClosed(datelist, tradingdays)+1]
} else {
stop("unsupported \"dir\" argument!")
}
re <- as.Date(re,origin="1970-01-01")
return(re)
}
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
sus_res <- TS.sus_res(TS)
if(dir == -1L){
re <- dplyr::mutate(sus_res,nearest=ifelse(is.na(sus),
trday.nearest(date,dir = -1L),
trday.nearby(sus,by=-1,stockID=NULL)))
} else if(dir == 1L){
re <- dplyr::mutate(sus_res,nearest=ifelse(is.na(sus),
trday.nearest(date,dir = 1L),
res))
} else {
stop("unsupported \"dir\" argument!")
}
re$nearest <- as.Date(re$nearest,origin="1970-01-01")
if(drop){
re <- re$nearest
}else {
re <- dplyr::select(re,-sus,-res)
}
return(re)
}
#' trday.nearby
#'
#' get the nearby tradingday by shifting forward or backward.If the argument datelist is not a tradingday,the tradingday nearest by it will be firstly found by function \code{trday.nearest(by=-1)}.
#' @param datelist a vector of class Date
#' @param by a integer giving the lagging days.If negetive,get the earlyer tradingday,if positive,get the later tradingday.
#' @param stockID a character string or null. If null, the market trading days, other wise the trading days of specific stock.
#' @param dir 1L or -1L. If the result is not trading day, get the nearest trading day, here need the dir param to give a shifting direction. see \code{\link{trday.nearest}}
#' @return a vector of trading days of class Date
#' @export
#' @author Ruifei.Yin
#' @examples
#' (datelist <- as.Date(c("2012-07-21","2012-07-22","2012-07-23","2013-01-30")))
#' trday.nearby(datelist,-20) # the tradingday 20 days earlyer than datelist
#' trday.nearby(datelist,20) # the tradingday 20 days later than datelist
#' trday.nearby(datelist,20,stockID="EQ000527")
trday.nearby <- function(datelist,by, stockID=NULL,
dir=if(by>0) 1L else -1L,
TS,
drop=FALSE){
if(is.null(stockID) & missing(TS)){ # the market tradingday
trdingday.all <- trday.get(endT=Sys.Date()+365, stockID=NULL)
trdlist <- trdingday.all[findInterval(datelist, trdingday.all)] # get the nearest tradingday
lag.trdingday.all <- xts::lag.xts(trdingday.all, -by)
idx <- match(trdlist, trdingday.all)
re <- lag.trdingday.all[idx]
return(re)
}
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
# get the market's nearby tradingday
nearby_market <- trday.nearby(TS$date,by=by,stockID=NULL)
# get the stock's nearest tradingday
nearby <- trday.nearest(TS=data.frame(date=nearby_market,stockID=TS$stockID),dir = dir,drop = TRUE)
if(drop){
re <- nearby
} else {
re <- cbind(TS,nearby)
}
return(re)
}
#' trday.offset
#'
#' offset the datelist by months,quarters,ect. then get the nearest tradingday
#' @param datelist a vector of class Date
#' @param by a period object. See detail in package \code{lubridate}.
#' @param dir 1L or -1L. if the result date is not trdingday, get the forward nearest tradingday or the backward tradingday? See detail in \link{trday.nearest}
#' @param stockID a character string or null. If null, the market trading days, other wise the trading days of specific stock.
#' @return a vector of trading days of class Date
#' @export
#' @author Ruifei.Yin
#' @examples
#' (datelist <- as.Date(c("2012-07-21","2012-07-22","2012-07-23","2013-01-30")))
#' trday.offset(datelist,months(1)) # the tradingdays 1 month after the datelist
#' trday.offset(datelist,months(-1)) # the tradingdays 1 month before the datelist
#' trday.offset(datelist,years(1))
#' trday.offset(datelist,months(-1),stockID="EQ000527")
trday.offset <- function(datelist,by=months(1),stockID=NULL,
dir=if(as.numeric(by)>0) 1L else -1L,
TS,
drop=FALSE){
if(is.null(stockID) & missing(TS)){ # the market tradingday
if (any(c(by@.Data, by@minute, by@hour, by@day) != 0)){
re <- datelist + by
} else { # if handles month and years, should use %m+%
re <- datelist %m+% by
}
re <- trday.nearest(re, dir=dir, stockID=NULL)
return(re)
}
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
# get the market's offset tradingday
offset_market <- trday.offset(TS$date,by=by,dir=dir,stockID=NULL)
# get the stock's offset tradingday
offset <- trday.nearest(TS=data.frame(date=offset_market,stockID=TS$stockID),dir = dir,drop = TRUE)
if(drop){
re <- offset
} else {
re <- cbind(TS,offset)
}
return(re)
}
#' trday.last
#'
#' get the last tradingday. If datelist is tradingday, return trday.nearby(by=-1), else, return trday.nearest(dir=-1)
#' @export
#' @examples
#' (datelist <- seq(from=as.Date("2013-01-21"),to=as.Date("2013-01-30"),by="day"))
#' trday.is(datelist)
#' # -- compare the following three output:
#' trday.last(datelist)
#' trday.nearest(datelist,dir=-1)
#' trday.nearby(datelist,by=-1)
#' # -- return TS
#' stockID=c("EQ000527","EQ000001")
#' trday.last(datelist = datelist,stockID=stockID)
trday.last <- function(datelist,stockID=NULL,TS,drop=FALSE){
if(is.null(stockID) & missing(TS)){ # the market tradingday
re <- datelist
istrday <- trday.is(datelist = datelist, stockID = NULL)
re[istrday] <- trday.nearby(datelist = datelist[istrday], by=-1, stockID=NULL)
re[!istrday] <- trday.nearest(datelist = datelist[!istrday], dir=-1, stockID=NULL)
return(re)
}
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
istrday <- trday.is(TS=TS,drop=TRUE)
TS_istrday <- trday.nearby(TS = TS[istrday,], by = -1)
TS_notrday <- trday.nearest(TS = TS[!istrday,], dir = -1)
re <- rbind(renameCol(TS_istrday,"nearby","last"), renameCol(TS_notrday,"nearest","last"))
re <- merge.x(TS,re,by=c("date","stockID"))
if(drop){
re <- re$last
}else {
re <- re
}
return(re)
}
#' trday.count
#'
#' get the count of the trading days between \code{begT} and \code{endT}.
#' @param begT a Date object.The default is as.Date("1990-12-19")
#' @param endT a Date object.The default is Sys.Date()
#' @param stockID a character string or null. If null, the market trading days, other wise the trading days of specific stock.
#' @return a integer
#' @export
#' @author Ruifei.Yin
#' @examples
#' trday.count(as.Date("2012-01-01"),as.Date("2012-09-30"))
#' trday.count(as.Date("2012-01-01"),as.Date("2012-09-30"),stockID="EQ000527")
trday.count <- function(begT=as.Date("1990-12-19"), endT=Sys.Date(), stockID=NULL){
trdate <- trday.get(begT,endT,stockID=stockID)
re <- length(trdate)
return(re)
}
#' trday.IPO
#' @param stockID a vector
#' @return a vector
#' @export
#' @family SecuMain functions
trday.IPO <- function(stockID,datasrc=defaultDataSRC()){
qr <- paste("select ListedDate,ID from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
re <- tmpdat[match(stockID,tmpdat[,2]),1]
re <- intdate2r(re)
return(re)
}
#' trday.unlist
#' @param stockID a vector
#' @return a vector
#' @export
#' @family SecuMain functions
trday.unlist <- function(stockID,datasrc="jy"){
if(datasrc=="jy"){
stocks <- substr(unique(stockID),3,8)
#get delist date
qr <- paste("SELECT 'EQ'+s.SecuCode 'stockID',convert(varchar,ChangeDate,112) 'delistdate'
FROM LC_ListStatus l
INNER join SecuMain s on l.InnerCode=s.InnerCode and s.SecuCategory=1
where l.ChangeType=4 and l.SecuMarket in (83,90)
and s.SecuCode in",brkQT(stocks))
tmpdat <- queryAndClose.odbc(db.jy(),qr,as.is = TRUE)
re <- tmpdat[match(stockID,tmpdat[,1]),2]
re <- intdate2r(re)
}
return(re)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# ==================== SecuMain related ==============
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' tradeCode2stockID
#'
#' Covert the tradeCode to stockID given specific secucategory.
#' @param tradeCode Vector of character,giving the stock trading code. eg. \code{c("600001","600002","000300")}
#' @param secuCate integer,giving the secuCategory.(1 for A equity,4 for index,...)
#' @param IDsrc a charactor string, could be one of "local","jy","ts","wind",etc.
#' @return a vector,return the stockID of specific datascr.
#' @export
#' @family SecuMain functions
#' @author Ruifei.Yin
#' @examples
#' tradeCode2stockID(c("600001","600002"),secuCate=1)
#' tradeCode2stockID(c("000001","000300"),secuCate=4)
tradeCode2stockID <- function(tradeCode, secuCate=1, IDsrc="local",
datasrc=defaultDataSRC()){
id_var <- switch(IDsrc,
local="ID",
quant="ID",
jy="InnerCode",
ts="StockID_TS",
wind="StockID_wind")
qr <- paste("select secucode,",id_var,"from SecuMain where secucategory=",secuCate)
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr,as.is=1)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
stockID <- tmpdat[match(tradeCode,tmpdat[,1]),2]
return(stockID)
}
intCode2tradeCode <- function(){
# 718-->"000718"
}
#' stockID2tradeCode
#'
#' Covert the stockID to tradeCode.
#' @param stockID a vector of stockID of specific datascr.
#' @param IDsrc a charactor string, could be one of "local","jy","ts","wind",etc.
#' @return a vector of character,giving the stock trading code. eg. \code{c("600001","600002","000300")}
#' @export
#' @family SecuMain functions
#' @author Ruifei.Yin
#' @examples
#' stockID2tradeCode(c("EI000001","EQ000030"),IDsrc="local")
#' stockID2tradeCode(c("SZ000001","SH000030"),IDsrc="ts")
stockID2tradeCode <- function(stockID,IDsrc="local",
datasrc=defaultDataSRC()){
id_var <- switch(IDsrc,
local="ID",
quant="ID",
jy="InnerCode",
ts="StockID_TS",
wind="StockID_wind")
qr <- paste("select secucode,",id_var,"from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr,as.is=1)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
tradeCode <- tmpdat[match(stockID,tmpdat[,2]),1]
return(tradeCode)
}
#' stockID2stockID
#'
#' Covert the stockID to another type of stockID.
#' @param stockID a vector of specific type
#' @param to a character string, giving the type of stockID convered to. Could be one of "local","ts","jy","wind".
#' @param from a character string, giving the type of stockID convered from. Could be one of "local","ts","jy","wind".
#' @return a vector,return the stockID of specific datascr.
#' @export
#' @family SecuMain functions
#' @author Ruifei.Yin
#' @examples
#' stockID2stockID(c("EI000001","EI000300"),to="jy",from="local")
#' stockID2stockID(c("SH000001","SH000300"),to="jy",from="ts")
stockID2stockID <- function(stockID, from, to,
datasrc=defaultDataSRC()){
id_from <- switch(from,
local="ID",
quant="ID",
jy="InnerCode",
ts="StockID_TS",
wind="StockID_wind")
id_to <- switch(to,
local="ID",
quant="ID",
jy="InnerCode",
ts="StockID_TS",
wind="StockID_wind")
qr <- paste("select",id_from,",",id_to,"from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
stockID_to <- tmpdat[match(stockID,tmpdat[,1]),2]
return(stockID_to)
}
#' stockID2name
#' @param stockID a vector
#' @return a vector
#' @export
#' @family SecuMain functions
#' @examples
#' stockID2name("EQ000527")
stockID2name <- function(stockID,datasrc=defaultDataSRC()){
qr <- paste("select SecuAbbr,ID from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
re <- tmpdat[match(stockID,tmpdat[,2]),1]
return(re)
}
#' stockName2ID
#' @param name a characoter vector
#' @return a dataframe with cols: 'SecuAbbr', 'ID'
#' @export
#' @family SecuMain functions
#' @examples
#' stockName2ID("ST")
stockName2ID <- function(name, datasrc=defaultDataSRC()){
qr <- paste("select SecuAbbr, ID from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
re <- tmpdat[grep(name, gsub("\\s*","",tmpdat$SecuAbbr)), ]
return(re)
}
#' SecuMarket
#' @param stockID a vector
#' @return a vector
#' @export
#' @family SecuMain functions
SecuMarket <- function(stockID,datasrc=defaultDataSRC()){
qr <- paste("select SecuMarket,ID from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
re <- tmpdat[match(stockID,tmpdat[,2]),1]
return(re)
}
#' SecuCategory
#' @param stockID a vector
#' @return a vector
#' @export
#' @family SecuMain functions
SecuCategory <- function(stockID,datasrc=defaultDataSRC()){
qr <- paste("select SecuCategory,ID from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
re <- tmpdat[match(stockID,tmpdat[,2]),1]
return(re)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== sector components & sectorID =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' getComps
#'
#' get the components of the specific index, sector or plate on certain days.
#' @param ID a character string. The ID of the index, sector or plate. Could be a single-ID-code(eg. "EI000300","ES09440000",...) or a more complicated express containing some set operations and ID-codes(eg. "setdiff(union(EI000300,EI000905),ES09440000)")
#' @param endT a vector of class \code{Date}. IF missing, then get the latest components.
#' @param drop if drop the field of date and return a vector when endT is length 1 ?
#' @return If \code{endT} is missing or is length 1 and \code{drop} is TRUE, a vector of stockID of the components; else a dataframe, with cols: "date" and "stockID"
#' @export
#' @family getComps functions
#' @examples
#' re1 <- getComps("EI000300") # same as getIndexComp("EI000300")
#' ID <- "setdiff(union(EI000300,EI399006),ES09440000)"
#' re2 <- getComps(ID)
#' re3 <- getComps(ID,endT=as.Date(c("2011-12-31","2012-12-31")))
#' more examples:
#' # CSI300 ex. financial servive sector
#' getComps("setdiff(EI000300,ES09440000)")
#' # CSI300 and financial servive sector
#' getComps("intersect(EI000300,ES09440000)")
#' # not drop
#' getComps("EI000300",drop=FALSE)
getComps <- function(ID, endT=Sys.Date(), drop=TRUE, datasrc=defaultDataSRC()){
IDs <- gsub("union|intersect|setdiff|[()]","",ID)
IDs <- strsplit(IDs,split=",")[[1]]
IDs <- unique(IDs[IDs!=""])
IDs_index <- IDs[substring(IDs,1,2)=="EI"]
IDs_sector <- IDs[substring(IDs,1,2)=="ES"]
IDs_plate <- IDs[substring(IDs,1,2)=="EP"]
if(length(IDs_index) > 0){
comp_index <- lapply(IDs_index, FUN=getIndexComp, endT=endT, drop=FALSE, datasrc=datasrc)
names(comp_index) <- IDs_index
} else {
comp_index <- list()
}
if(length(IDs_sector) > 0){
comp_sector <- lapply(IDs_sector, FUN=getSectorComp, endT=endT, drop=FALSE, datasrc=datasrc)
names(comp_sector) <- IDs_sector
} else {
comp_sector <- list()
}
if(length(IDs_plate) > 0){
comp_plate <- lapply(IDs_plate, FUN=getPlateComp, endT=endT, drop=FALSE, datasrc=datasrc)
names(comp_plate) <- IDs_plate
} else {
comp_plate <- list()
}
comps <- c(comp_index,comp_sector,comp_plate)
subfun <- function(endT0){
comps0 <- lapply(comps,function(x) x[x$date==endT0,"stockID"] )
dat0 <- with(comps0,eval(parse(text=ID)))
dat0 <- data.frame(date=endT0,stockID=dat0,stringsAsFactors=FALSE)
return(dat0)
}
re <- plyr::ldply(endT, subfun)
if(length(endT)==1 && drop==TRUE){
return(re$stockID)
} else {
return(re)
}
}
#' getIndexComp
#'
#' get the components of the specific index on certain day.
#' @param indexID the stockID of the index
#' @param endT a vector of class \code{Date}. IF missing, then get the latest components.
#' @param drop if drop the field of date and return a vector when endT is length 1 ?
#' @return If \code{endT} is missing or is length 1 and \code{drop} is TRUE, a vector of stockID of the components; else a dataframe, with cols: "date" and "stockID"
#' @export
#' @examples
#' tmp <- getIndexComp("EI000300",drop=TRUE) # get the latest components, a vector
#' tmp <- getIndexComp("EI000300") # get the latest components, a dataframe
#' tmp <- getIndexComp("EI000300",as.Date("2012-12-31")) # get the components on single day,a vector
#' tmp <- getIndexComp("EI000300",as.Date(c("2011-12-31","2012-12-31"))) # get the components on multi-days, a data frame
#' tmp <- getIndexComp("EI000300",as.Date(c("2005-12-31","2012-12-31"))) # get the components before index's pubdate, a data frame
getIndexComp <- function(indexID, endT=Sys.Date(), drop=FALSE, datasrc=defaultDataSRC()){
pubdate <- trday.IPO(indexID)
endTdf <- data.frame(dateori=endT,date=endT)
if(indexID!='EI000985' && (!is.na(pubdate)) && min(endT)<pubdate){
warning(paste("min(endT):",min(endT)," is earlier than index's published date:",pubdate,". The early components would be approximated!",sep=""))
endT[endT<pubdate] <- pubdate
endTdf <- transform(endTdf,date=endT)
endT <- unique(endT)
}
if(datasrc %in% c("quant","local")){
endT <- rdate2int(endT)
tmpdat <- data.frame(endT=endT)
qr <- paste("SELECT a.endT as date, b.SecuID as stockID from temp_table a, LC_IndexComponent b
where b.IndexID=", QT(indexID),
"and InDate<=endT and (OutDate>endT or OutDate IS NULL)")
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con, sqtable="temp_table", errors=FALSE)
sqlSave(con, dat=tmpdat, tablename="temp_table", safer=FALSE, rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
dbWriteTable(con, name="temp_table", value=tmpdat, row.names = FALSE, overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re$date <- intdate2r(re$date)
}
if(datasrc=="ts"){
endT <- rdate2ts(endT)
indexID <- stockID2stockID(indexID,to="ts",from="local")
subfun <- function(endT0){
tsRequire()
stocks <- tsRemoteCallFunc("GetBKbyDate",list(indexID,endT0))
stocks <- as.vector(as.matrix(stocks))
stocks <- stockID2stockID(stocks,to="local",from="ts")
dat0 <- data.frame(date=tsdate2r(endT0),stockID=stocks,stringsAsFactors=FALSE)
return(dat0)
}
re <- plyr::ldply(endT,subfun)
}
endT <- endTdf$dateori
if(indexID!='EI000985' && (!is.na(pubdate)) && min(endT)<pubdate){
re <- endTdf %>% dplyr::full_join(re,by='date') %>% dplyr::select(-date) %>% dplyr::rename(date=dateori)
ipo <- data.frame(stockID=unique(re$stockID),stringsAsFactors = FALSE)
ipo$ipoday <- trday.IPO(ipo$stockID)
re <- re %>% dplyr::left_join(ipo,by='stockID') %>% dplyr::mutate(gap=date-ipoday) %>%
dplyr::filter(gap>=90) %>% dplyr::select(-ipoday,-gap)
}
re <- dplyr::arrange(re,date,stockID)
if(length(endT)==1 && drop==TRUE){
return(re$stockID)
} else {
return(re)
}
}
#' getIndexCompWgt
#'
#' get the components and wgts of the specific index on certain day.
#' @param indexID the stockID of the index
#' @param endT a vector of class \code{Date}. IF missing, then get the latest components.
#' @return a dataframe, with cols: "date", "stockID","wgt".
#' @export
#' @family getComps functions
#' @examples
#' tmp <- getIndexCompWgt("EI000300") # get the latest components
#' tmp <- getIndexCompWgt("EI000985",as.Date("2012-12-31")) # get the components on single day
#' tmp <- getIndexCompWgt("EI000300",as.Date(c("2011-12-31","2012-12-31"))) # get the components on multi-days
getIndexCompWgt <- function(indexID="EI000300",endT,datasrc=defaultDataSRC()){
if(missing(endT)) endT <- trday.nearby(Sys.Date(),by=-1) # if endT missing, get the nearest wgt data.
endT <- trday.nearest(endT) # if endT is not tradingday, get the nearest trading days.
trday.nearbyinDB <- function(indexID,endT,datasrc){
# sometimes, the index-component-weight in database is not daily data, this function is used to get nearest date on which the weight data is available.
daymat <- data.frame(oldday=endT)
endT <- rdate2int(endT)
qr <- paste(
"SELECT DISTINCT EndDate
FROM LC_IndexComponentsWeight
where IndexID=",QT(indexID),"order by EndDate"
)
if(datasrc=="quant"){
con <- db.quant()
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
re <- dbGetQuery(con,qr)
dbDisconnect(con)
} else if (datasrc=="jy"){
con <- db.jy()
indexID <- stockID2stockID(indexID,to="jy",from="local")
qr <- paste(
"SELECT DISTINCT convert(varchar,EndDate,112) 'EndDate'
FROM LC_IndexComponentsWeight
where IndexCode=",QT(indexID),"order by EndDate"
)
re <- sqlQuery(con,query=qr)
odbcClose(con)
}
if(nrow(re)==0){
return(0)
}
if(min(endT)<min(re$EndDate)){
return(0)
} else{
endT<- re[findInterval(endT,re$EndDate),]
daymat$newday <- endT
return(daymat)
}
}
daymat <- trday.nearbyinDB(indexID,endT,datasrc)
if(is.numeric(daymat)){ # -- calulate the estimated wgt by 'free_foat_MV'
warning("There is no wgt data in table 'LC_IndexComponentsWeight', calulate the estimated wgt by 'free_foat_MV'.")
# TS <- getTS(endT,indexID)
TS <- getIndexComp(indexID = indexID ,endT = endT, drop = FALSE,datasrc=datasrc)
TSF <- gf_cap(TS,var = 'free_cap',na_fill = FALSE,datasrc="memory")
re <- TSF %>% dplyr::mutate(factorscore=ifelse(is.na(factorscore),0,factorscore)) %>%
group_by(date) %>%
dplyr::mutate(wgt=factorscore/sum(factorscore,na.rm=TRUE)) %>%
dplyr::ungroup() %>% dplyr::select(date,stockID,wgt)
re <- as.data.frame(re)
return(re)
}
endT <- unique(daymat$newday)
if(datasrc %in% c("quant","local")){
tmpdat <- data.frame(endT=endT)
qr <- paste("SELECT a.endT as date, b.SecuID as stockID, Weight/100 as wgt
from temp_table a, LC_IndexComponentsWeight b
where b.IndexID=", QT(indexID),
"and a.endT=b.EndDate")
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con, sqtable="temp_table", errors=FALSE)
sqlSave(con, dat=tmpdat, tablename="temp_table", safer=FALSE, rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
dbWriteTable(con, name="temp_table", value=tmpdat, row.names = FALSE, overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re=merge(re,daymat,by.x="date",by.y ="newday" )
re=re[,c("oldday","stockID","wgt")]
colnames(re)<-c("date","stockID","wgt")
}
if(datasrc=="jy"){
indexID <- stockID2stockID(indexID,to="jy",from="local")
subfun <- function(endT0){
qr <- paste(
"SELECT InnerCode as stockID, Weight/100 as wgt
FROM LC_IndexComponentsWeight as a
where IndexCode=",QT(indexID) ,"and a.EndDate=",QT(endT0)
)
dat <- queryAndClose.odbc(db.jy(),query=qr)
if(nrow(dat)==0){
warning(paste("weight data is missing on",endT0,"!"))
} else {
dat <- data.frame(date=intdate2r(endT0),dat,stringsAsFactors=FALSE)
}
return(dat)
}
re <- plyr::ldply(endT,subfun,.progress="text")
re$stockID <- stockID2stockID(re$stockID,to="local",from="jy")
}
re <- dplyr::arrange(re,date,stockID)
return(re)
}
#' getSectorComp
#'
#' get the components of the specific sector on certain day.
#' @param sectorID ID of the sector. eg. "ES09440000" for "financial service" the 1st level sector of SHENWAN; "ES09440100" for "bank" the 2nd level sector of SHENWAN. Get details with \code{CT_industryList()}
#' @param endT a vector of class \code{Date}. IF missing, then get the latest components.
#' @param drop if drop the field of date and return a vector when endT is length 1 ?
#' @return If \code{endT} is missing or is length 1 and \code{drop} is TRUE, a vector of stockID of the components; else a dataframe, with cols: "date" and "stockID"
#' @export
#' @family getComps functions
#' @examples
#' tmp <- getSectorComp("ES09440000") # get the latest components, a vector
#' tmp <- getSectorComp("ES09440000",as.Date("2012-12-31")) # get the components on single day,a vector
#' tmp <- getSectorComp("ES09440000",as.Date(c("2011-12-31","2012-12-31"))) # get the components on multi-days, a data frame
getSectorComp <- function(sectorID, endT=Sys.Date(), drop=TRUE, datasrc=defaultDataSRC()){
level <- CT_industryList(ID=sectorID)$Level
sectorVar <- paste("Code",level,sep="")
if(datasrc %in% c("quant","local")){
endT <- rdate2int(endT)
tmpdat <- data.frame(endT=endT)
qr <- paste("SELECT a.endT as date, b.stockID as stockID from temp_table a, LC_ExgIndustry b
where ",sectorVar,"=", QT(sectorID),
"and InDate<=endT and (OutDate>endT or OutDate IS NULL)")
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con, sqtable="temp_table", errors=FALSE)
sqlSave(con, dat=tmpdat, tablename="temp_table", safer=FALSE, rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
dbWriteTable(con, name="temp_table", value=tmpdat, row.names = FALSE, overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re$date <- intdate2r(re$date)
}
re <- dplyr::arrange(re,date,stockID)
if(length(endT)==1 && drop==TRUE){
return(re$stockID)
} else {
return(re)
}
}
#' @family getComps functions
getPlateComp <- function(plateID,endT,drop,datasrc){
}
#' sectorID2name
#' @export
sectorID2name <- function(sectorID){
tmpdat <- CT_industryList(ID=sectorID)
tmpdat <- tmpdat[,c("IndustryID","IndustryName")]
re <- tmpdat[match(sectorID,tmpdat[,1]),2]
return(re)
}
plateID2name <- function(plateID){
}
#' sectorID2indexID
#' @export
#' @examples
#' sctID <- getSectorID(stockID = "EQ000001",drop=TRUE)
#' sectorID2indexID(sctID)
sectorID2indexID <- function(sectorID,std=24){
qr <-paste("select A.IndustryCode 'sector',B.SecuCode
from LC_CorrIndexIndustry A,SecuMain B
where A.IndexCode = B.InnerCode and A.IndexState in (1,2) and A.IndustryStandard=",std)
tmpdat <- queryAndClose.odbc(db.jy(),qr,stringsAsFactors =FALSE)
if(std==24){
tmpdat$sector <- paste0("ES33",tmpdat$sector)
}else if(std==9){
tmpdat$sector <- paste0("ES09",tmpdat$sector)
}else if(std==3){
tmpdat$sector <- paste0("ES03",tmpdat$sector)
}
re <- tmpdat[match(sectorID,tmpdat[,1]),2]
if(std %in% c(9,24)){
re <- paste0("EI",re)
}
return(re)
}
#' stockID2indexID
#' @export
#' @examples
#' stockID2indexID(stockID = "EQ000001")
stockID2indexID <- function(TS, stockID, withsector = FALSE){
re <- getSectorID(TS = TS, stockID = stockID)
re$indexID <- sectorID2indexID(re$sector)
if(!withsector){
re <- dplyr::select(re, -sector)
}
return(re)
}
#' getSectorID
#'
#' get the sectorID of the stocks on specific dates.
#' @param TS a \bold{TS} object
#' @param stockID a vector of stockID
#' @param endT a vector of Date
#' @param sectorAttr a list(See more in \code{\link{defaultSectorAttr}}) or NULL,or "existing".
#' @param ret a charactor string,could be one of "ID" or "name",indicating sectorID or sectorName returned.
#' @param drop a logical. Shoud the \code{TS} be exculded in the result?
#' @param fillNA logical.
#' @param ungroup integer, or NULL.
#' @return a data.frame,with the same cols of TS,added by "\code{sector}". Or a vector if \code{drop} is TRUE. You can get more sector infomation by \code{\link{CT_industryList}}
#' @note param TS and combination of stockID and endT should at least have one and only have one. The combination of vector stockID and endT could be different length, which abide by the recycling rule.
#' @author Ruifei.Yin
#' @export
#' @examples
#' # - with TS
#' TS <- getTS(getRebDates(as.Date('2007-03-17'),as.Date('2012-05-20')),'EI000300')
#' getSectorID(TS)
#' # - one stock, multiple dates
#' getSectorID(stockID="EQ000001", endT=as.Date(c("2010-01-01","2012-01-01","2013-01-01")))
#' # - one date, multiple stocks
#' getSectorID(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2010-01-01"))
#' # - get 'ZHONGXIN' sector
#' getSectorID(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2010-01-01"), sectorAttr=list(3,1), ret="name")
#' getSectorID(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2010-01-01"), sectorAttr=list(3,2), ret="name")
#' # -- combined sectorAttr
#' test <- getSectorID(TS, sectorAttr= defaultSectorAttr("fct",fct_level = 5))
#' test <- getSectorID(TS, sectorAttr= defaultSectorAttr("ind_fct",ind_std = 33,ind_level = 1,fct_level = 5))
#' test <- getSectorID(TS, sectorAttr= defaultSectorAttr("ind_fct",ind_std = c(336,33),ind_level = 1,fct_level = 5))
#' test <- getSectorID(TS, sectorAttr= defaultSectorAttr("fct",fct_std = buildFactorLists_lcfs(c("F000001","F000006"),factorRefine = refinePar_default("none",NULL)),fct_level = 5))
#' factorList1 <- buildFactorList(factorFun = "gf_cap",factorRefine=refinePar_default("scale",NULL))
#' test2 <- getSectorID(TS, sectorAttr= list(std=list(factorList1,33),level=list(5,1)))
#' # - speed compares (20 VS. 200)
#' microbenchmark::microbenchmark(re <- getSectorID(TS,datasrc="memory"),re1 <- getSectorID(TS,datasrc = "local"),times = 10)
getSectorID <- function(TS, stockID, endT=Sys.Date(),
sectorAttr=defaultSectorAttr(),
ret=c("ID","name"),
drop=FALSE,
fillNA=FALSE,
ungroup=NULL,
datasrc="memory"){
if(identical(sectorAttr,"existing") | is.null(sectorAttr)){
return(TS)
}
# arguments checking
ret <- match.arg(ret)
if (missing(TS) && missing(stockID)) {
stop("Param TS and combination of stockID and endT should at least have one!")
}
if (!missing(TS) && !missing(stockID)) {
stop("Param TS and combination of stockID and endT should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=endT, stockID=stockID)
}
names(sectorAttr) <- c("std","level")
if(length(sectorAttr$std) != length(sectorAttr$level)) stop("The argument of sectorAttr is not complete.")
if("sector" %in% colnames(TS)){
warning('There is already a "sector" field in TS, it will be overwritten!')
TS$sector <- NULL
}
# looping
loop <- length(sectorAttr$std)
for( i in 1:loop) {
if(is.numeric(sectorAttr$std[[i]])){ # by industrys
sectorSTD <- sectorAttr$std[[i]]
level <- sectorAttr$level[[i]]
sectorvar <- if (ret=="ID") paste("Code",level,sep="") else paste("Name",level,sep="")
TS_ <- TS[,c("date","stockID")]
if(datasrc %in% c("quant","local")){
TS_$date <- rdate2int(TS_$date)
qr <- paste(
"select date,a.stockID,",sectorvar,"as sector_
from temp_table as a left join LC_ExgIndustry as b
on a.stockID=b.stockID and InDate<=date and (OutDate>date or OutDate is null)
where b.Standard=",sectorSTD
)
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=TS_,tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
dbWriteTable(con,name="temp_table",value=TS_,row.names = FALSE,overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re$date <- intdate2r(re$date)
TS <- merge.x(TS,re,by=c("date","stockID"))
} else if (datasrc=="memory"){
memory.load()
TS_ <- data.table::data.table(TS_)
LC_ExgIndustry <- .LC_ExgIndustry[Standard==sectorSTD]
re <- LC_ExgIndustry[TS_,c("date","stockID",paste("x.",sectorvar,sep="")),on=.(stockID,InDate<=date,OutDate>date),with=FALSE]
re <- renameCol(re,paste("x.",sectorvar,sep=""),"sector_")
re <- as.data.frame(re)
TS <- merge.x(TS,re,by=c("date","stockID"))
}
if(fillNA){
TS$sector_ <- sector_NA_fill(sector = TS$sector_, sectorAttr = list(std = sectorSTD, level = level))
}
} else { # by factors
factorList <- sectorAttr$std[[i]]
level <- sectorAttr$level[[i]]
tmpTS <- TS[,c("date","stockID")]
tmpTSF <- getTSF(TS = tmpTS, FactorList = factorList)
tmpTSF <- dplyr::group_by(tmpTSF, date)
tmpTSF <- dplyr::mutate(tmpTSF,sector_=cut(rank(-factorscore,na.last="keep"),breaks =level,labels=FALSE))
tmpTSF <- dplyr::select(tmpTSF,-factorscore)
TS <- merge.x(TS,tmpTSF, by=c("date","stockID"))
}
# join together
if(i==1L){
TS <- renameCol(TS,"sector_","sector")
} else {
TS$sector <- paste(TS$sector, TS$sector_, sep="_")
TS <- dplyr::select(TS,-sector_)
}
}
# ungroup
if(!is.null(ungroup)){
TS <- sector_ungroup(TS,N=ungroup)
}
# return
if(drop){
return(TS[,"sector"])
} else {
return(TS)
}
}
#' is component of specific sector or index?
#'
#' @param sectorID a character string. The ID of the index, sector or plate. See detail in \code{\link{getComps}}
#' @return a dataframe or a vector(if drop==TRUE)
#' @export
#' @examples
#' is_component(stockID = c("EQ000001","EQ300089"),sectorID = "EI000300",drop=TRUE)
#' is_component(stockID = c("EQ000001","EQ300089"),sectorID = "ES09440000")
#' TS <- getTS(as.Date(c("2014-01-01","2016-01-01")),indexID = "EI000906")
#' re <- is_component(TS,sectorID = "EI000300")
is_component <- function(TS, stockID, endT=Sys.Date(),
sectorID,
drop=FALSE,
datasrc=defaultDataSRC()){
if (missing(TS) && missing(stockID)) {
stop("Param TS and combination of stockID and endT should at least have one!")
}
if (!missing(TS) && !missing(stockID)) {
stop("Param TS and combination of stockID and endT should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=endT, stockID=stockID)
}
indexComp <- getComps(sectorID,unique(TS$date),drop = FALSE,datasrc = datasrc)
indexComp$is_comp <- 1L
TSF <- merge.x(TS,indexComp,by=c('date','stockID'))
TSF[is.na(TSF$is_comp),"is_comp"] <- 0
if(drop){
return(TSF[,"is_comp"])
} else {
return(TSF)
}
}
#' deal with the NA value of sectorID
#'
#' replace the NA value of sectorID with an "OTHER" sector
#' @param sector a charactor vector of sectorID
#' @export
sector_NA_fill <- function(sector, sectorAttr=defaultSectorAttr()){
Standard=c( 3, 3, 3, 9, 9, 9, 9, 9, 33, 33, 33, 336)
Level=c( 1, 2, 3, 1, 2, 3, 98, 99, 1, 2, 3, 1)
IndustryID=c( 'ES0370', 'ES037010', 'ES03701010', 'ES09510000', 'ES09510100', 'ES09510101', 'ES0951000098', 'ES0951000099', 'ES33510000','ES33510100','ES33510101', 'ES6')
replace_sec_value <- IndustryID[Standard==sectorAttr[[1]]&Level==sectorAttr[[2]]]
sector[is.na(sector)] <- replace_sec_value
return(sector)
}
# inner-func
# Turn two-stage group ID to one-stage when group members is less than a certain number.
sector_ungroup <- function(TSS,N=10){
if(stringr::str_detect(TSS[1,"sector"],'_') && substr(TSS$sector,1,2)=="ES"){
nsector <- TSS %>% group_by(date,sector) %>% summarise(num=n()) %>% ungroup()
if(any(nsector$num<N)){
nsector <- tidyr::separate(nsector,'sector',c("ind","fct"),sep="_",remove=FALSE)
nsector <- nsector %>% group_by(date,ind) %>% mutate(minnum=min(num)) %>% ungroup()
nsector <- transform(nsector,
sectornew=ifelse(minnum<N,ind,stringr::str_c(ind,fct,sep="_")))
TSS <- dplyr::left_join(TSS,nsector[,c("date","sector","sectornew")],by=c('date','sector'))
TSS <- transform(TSS,sector=sectornew,sectornew=NULL)
}
}
return(TSS)
}
#' @rdname getSectorID
#' @export
gf_sector <- function(TS, sectorAttr) {
TSS <- getSectorID(TS,sectorAttr = sectorAttr,fillNA = TRUE)
re <- cast_sector(TSS)
return(re)
}
#' @rdname getSectorID
#' @param TSS a dataframe, with cols: date,stockID,and some dummy variables of sectors.
#' @export
cast_sector <- function(TSS){
check.TSS(TSS)
TSS$.tmp <- 1
re <- reshape2::dcast(TSS,date+stockID~sector,fill=0,value.var = '.tmp')
TSS$.tmp <- NULL
re <- merge.x(TSS,re,by = c("date","stockID"))
return(re)
}
#' check.colnames_sectorfs
#'
#' @export
check.colnames_sectorfs <- function(data){
check.colnames(data,"sector")
cols <- colnames(data)
if(!any(substr(cols,1,2)=="ES")){
stop("the data must contain the sector-factors!")
}
}
#' defaultSectorAttr
#'
#' get the sectorAttr list.
#' @param type Currently supporting types : ind, fct, ind_fct, fct_ind
#' @param ind_std vector of integer.
#' @param ind_level vector of integer
#' @param fct_std a \bold{FactorLists} object
#' @param fct_level vector of integer. The number of fct splitted groups.
#' @return A \bold{sectorAttr} object. A list with two items:
#' \itemize{
#' \item std: a list( or a vector, if sector standards only include industry, not include factors) of sector standard;
#' \item level: a vector of sector level
#' }
#' @export
#' @examples
#' defaultSectorAttr()
#' defaultSectorAttr("ind",ind_std=c(3,33))
#' defaultSectorAttr("fct")
#' defaultSectorAttr("ind_fct")
#' defaultSectorAttr("fct_ind")
#' defaultSectorAttr("ind_fct",fct_level=5)
#' defaultSectorAttr("ind_fct",fct_std = RFactorModel::buildFactorLists_lcfs(c("F000001","F000006")),fct_level=c(2,3))
defaultSectorAttr <- function(type = c("ind","fct","ind_fct","fct_ind"),
ind_std = 33,
ind_level=1,
fct_std = list(fl_cap()),
fct_level = 3){
type <- match.arg(type)
if(length(ind_std)>length(ind_level)){
ind_level <- rep(ind_level,length(ind_std))
}
if(length(fct_std)>length(fct_level)){
fct_level <- rep(fct_level,length(fct_std))
}
if(type == "ind"){
re <- list(std = ind_std, level = ind_level)
} else if(type =="fct"){
re <- list(std = fct_std, level = fct_level)
} else if(type == "ind_fct"){
re <- list(std = c(as.list(ind_std), fct_std), level = c(ind_level, fct_level))
} else if (type == "fct_ind"){
re <- list(std = c(fct_std, as.list(ind_std)), level = c(fct_level, ind_level))
}
return(re)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== Constant value infomation =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' CT_SystemConst
#' @export
#' @examples
#' CT_SystemConst(LB=1081)
CT_SystemConst <- function(LB,datasrc=defaultDataSRC()){
qr <- "select * from CT_SystemConst"
if(datasrc=="local"){
re <- queryAndClose.dbi(db.local("main"),qr)
} else if(datasrc=="quant"){
re <- queryAndClose.odbc(db.quant(),qr)
} else if(datasrc=="jy"){
re <- queryAndClose.odbc(db.jy(),qr)[,c("LB","LBMC", "DM","MS")]
}
if(!missing(LB)){
re <- re[re$LB==LB,]
}
return(re)
}
#' CT_SecuCategory
#' @export
#' @examples
#' CT_SecuCategory(DM=c(1,4))
#' CT_SecuCategory(MS="xxx")
#' CT_SecuCategory()
CT_SecuCategory <- function(DM,MS){
re <- CT_SystemConst(LB=1177)
if(!missing(DM)){
re <- re[re$DM %in% DM, ]
}
if(!missing(MS)){
re <- re[grep(MS,re$MS),]
}
return(re)
}
#' CT_SecuMarket
#' @export
#' @examples
#' CT_SecuMarket(DM=c(83,90))
#' CT_SecuMarket(MS="xxx")
#' CT_SecuMarket()
CT_SecuMarket <- function(DM,MS){
re <- CT_SystemConst(LB=201)
if(!missing(DM)){
re <- re[re$DM %in% DM, ]
}
if(!missing(MS)){
re <- re[grep(MS,re$MS),]
}
return(re)
}
#' CT_sectorSTD
#' @export
#' @examples
#' CT_sectorSTD(DM=9)
#' CT_sectorSTD(DM=c(3,9))
#' CT_sectorSTD(MS="xxx")
#' CT_sectorSTD()
CT_sectorSTD <- function(DM,MS){
re <- CT_SystemConst(LB=1081)
if(!missing(DM)){
re <- re[re$DM %in% DM, ]
}
if(!missing(MS)){
re <- re[grep(MS,re$MS),]
}
return(re)
}
#' CT_industryList
#' @export
#' @examples
#' re <- CT_industryList(std=c(9,3))
#' CT_industryList(std=9,level=1)
#' CT_industryList(ID=c("ES0310","ES0312"))
#' CT_industryList(name="SHENWAN")
CT_industryList <- function(std,level,ID,name,
datasrc=defaultDataSRC()){
qr <- "select * from CT_IndustryList"
if(datasrc=="local"){
re <- queryAndClose.dbi(db.local("main"),qr)
} else if(datasrc=="quant"){
re <- queryAndClose.odbc(db.quant(),qr)
}
if(!missing(std)){
re <- re[re$Standard %in% std, ]
}
if(!missing(level)){
re <- re[re$Level %in% level, ]
}
if(!missing(ID)){
re <- re[re$IndustryID %in% ID, ]
}
if(!missing(name)){
re <- re[grep(name,re$IndustryName),]
}
return(re)
}
#' CT_TechVars
#' @export
CT_TechVars <- function(datasrc,secuCate,tableName,vars){
# -- Only local database allowed!
re <- queryAndClose.dbi(db.local("main"),"select * from CT_TechVars")
if(! missing(datasrc)){
re <- re[re$datasrc==datasrc,]
}
if(! missing(secuCate)){
re <- re[re$secuCate==secuCate,]
}
if(! missing(tableName)){
re <- re[re$tableName==tableName,]
}
if(! missing(vars)){
re <- re[re$varName %in% vars,]
}
return(re)
}
#' CT_FactorLists
#' @export
CT_FactorLists <- function(factorID,factorName,factorType,type = c("all", "alpha", "risk")){
# -- Only local database allowed!
type <- match.arg(type)
if(type == "all"){
re1 <- queryAndClose.dbi(db.local("fs"),"select * from CT_FactorLists")
re2 <- queryAndClose.dbi(db.local("fs_r"),"select * from CT_FactorLists_R")
re <- rbind(re1, re2)
}else if(type == "alpha"){
re <- queryAndClose.dbi(db.local("fs"),"select * from CT_FactorLists")
}else if(type == "risk"){
re <- queryAndClose.dbi(db.local("fs_r"),"select * from CT_FactorLists_R")
}
#
if(! missing(factorID)){
re <- re[match(factorID,re[,1]),]
}
if(! missing(factorName)){
re <- re[re$factorName %in% factorName,]
}
if(! missing(factorType)){
re <- re[re$factorType %in% factorType,]
}
#
return(re)
}
#' factorID2name
#' @export
factorID2name <- function(factorID){
re <- CT_FactorLists(factorID)$factorName
return(re)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== Future related =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' getIFlastfirstday
#'
#' get the first,last and open dates of all IFs.
#'
#' Note that the "firstday" is the date when the current-month IF switching,while the "openday" is the date the IF IPOing.
#' @param begM beginning month,a yearmon object.
#' @param endM ending month,a yearmon object.
#' @return a dataframe,with cols: date(of class Date),IF01(of class character) and firstday,lastday,openday(of class Date)
#' @export
#' @author Ruifei.Yin
#' @examples
#' getIFlastfirstday()
getIFlastfirstday <- function(begM=zoo::as.yearmon("2010-05"),endM=zoo::as.yearmon(Sys.Date())){
dt <- seq(from=zoo::as.Date(zoo::as.yearmon("2010-05")),to=Sys.Date()+1/12,by="month")
IF01 <- paste("IF",substr(as.character(dt),3,4),substr(as.character(dt),6,7),sep="")
# ---- lastday
lastday0 <- as.Date(timeDate::timeNthNdayInMonth(dt,5,3))
lastday <- as.Date(ifelse(trday.is(lastday0)|(lastday0>=Sys.Date()),lastday0,trday.nearby(lastday0,1)))
# ---- firstday
lastday_lag <-lag.m(lastday,1,TRUE)
firstday <- as.Date(ifelse(dt!=as.Date("2010-05-01"),trday.nearby(lastday_lag,1),as.Date("2010-04-16")))
firstday <- as.Date(ifelse(lastday_lag>=Sys.Date()&(!is.na(lastday_lag)),lastday_lag+3,firstday)) # this is a very tricky method!
# ---- openday
openday <- vector(length=length(dt))
for(ii in 1:length(dt)){
mm <-month(dt[ii])
if(mm %in% c(3,6,9,12)){
if(ii<=7){
openday[ii] <-as.Date("2010-04-16")
} else {
openday[ii] <-firstday[ii-7]
}
} else {
if(ii<=1){
openday[ii] <-as.Date("2010-04-16")
} else {
openday[ii] <-firstday[ii-1]
}
}
}
openday <- as.Date(openday)
# ---- merge and subset
re <- data.frame(date=dt,IF01,firstday,lastday,openday,stringsAsFactors=FALSE)
begM <- max(zoo::as.yearmon("2010-05"),begM)
endM <- min(zoo::as.yearmon(Sys.Date())+1/12,endM)
re <- re[re$date>=as.Date(begM)&re$date<=as.Date(endM),]
return(re)
}
#' getIFlist
#'
#' get the list(the 4 future at one time) of codes of all CSI300 index futures and the first and last day of every current-month future.
#' @param begM beginning month,a yearmon object.
#' @param endM ending month,a yearmon object.
#' @return a dataframe,with cols: date,IF01,IF02,IF03,IF04,firstday,lastday,openday
#' @export
#' @author Ruifei.Yin
#' @examples
#' getIFlist()
getIFlist <- function(begM=zoo::as.yearmon("2010-05"),endM=zoo::as.yearmon(Sys.Date())){
begM <- max(zoo::as.yearmon("2010-05"),begM)
endM <- min(zoo::as.yearmon(Sys.Date())+1/12,endM)
d1 <- seq(from=as.Date(begM),to=as.Date(endM),by="month")
d2 <- d1+months(1)
d3 <- vector(length=length(d1))
for(i in 1:length(d1)){
mm <-month(d1[i])
if(mm %in% c(1,4,7,10)){d3[i] <-d1[i]+months(2)}
if(mm %in% c(2,5,8,11)){d3[i] <-d1[i]+months(4)}
if(mm %in% c(3,6,9,12)){d3[i] <-d1[i]+months(3)}
}
d3 <- as.Date(d3)
d4 <- d3+months(3)
IF01 <- paste("IF",substr(as.character(d1),3,4),substr(as.character(d1),6,7),sep="")
IF02 <- paste("IF",substr(as.character(d2),3,4),substr(as.character(d2),6,7),sep="")
IF03 <- paste("IF",substr(as.character(d3),3,4),substr(as.character(d3),6,7),sep="")
IF04 <- paste("IF",substr(as.character(d4),3,4),substr(as.character(d4),6,7),sep="")
IFlist <- data.frame(date=d1,IF01,IF02,IF03,IF04,stringsAsFactors=FALSE)
IFlastfirstday <- getIFlastfirstday(begM,endM)
re <- merge(IFlist,IFlastfirstday)
return(re)
}
#' getIFcontinuousCode
#'
#' get the continuous index future code on every trading day
#' @return a datafame with cols:tradingday,IF00,IF01,IF02,IF03,IF04,firstday,lastday...
#' @export
#' @author Ruifei.Yin
#' @examples
#' begT <- as.Date("2010-04-16")
#' endT <- Sys.Date()
#' getIFcontinuousCode()
getIFcontinuousCode <- function(begT=as.Date("2010-04-16"),endT=Sys.Date()){
tradingday <- data.frame(tradingday=trday.get(begT,endT),stringsAsFactors=FALSE)
IFlist <- getIFlist()
sqlchar1 <- "select * from tradingday as a ,IFlist as b
where a.tradingday <= b.lastday and a.tradingday >= b.firstday"
re <- sqldf(sqlchar1)
return(re)
}
#' getIFrtn
#'
#' get index future daily return series
#' @param code the code of the future(eg."IF00","IF01","IF02"...)
#' @param begT an object of class "Date"
#' @param endT an object of class "Date"
#' @param adj a logical,with default FALSE. if true, the daily return of future will be aligned with the trading time(starting from 9:30 and ending to 15:30) of CSI300 index.
#' @return the daily return series of class xts.
#' @export
#' @author Ruifei.Yin
#' @examples
#' begT <- as.Date("2011-01-01")
#' endT <- as.Date("2011-02-01")
#' rtn <- getIFrtn("IF00",begT,endT)
#' rtn.adj <- getIFrtn("IF00",begT,endT,adj=TRUE)
getIFrtn <- function(code,begT,endT,adj=FALSE){
qt <- getQuote_ts(code,begT,endT,variables=c("price","yclose"),Cycle="cy_15m()")
rtn <- qt$price/qt$yclose-1
time <- qt$date
time.adj<- time
for(ii in 1:length(time)){
if(lubridate::hour(time[ii])==15 & lubridate::minute(time[ii])==15){
time.adj[ii] <- time[ii+1]-3600
}
}
if(adj){
rtn.xts <- xts(rtn,time.adj)
} else {
rtn.xts <- xts(rtn,time)
}
rtn.daily <- aggregate(rtn.xts,by=zoo::as.Date,PerformanceAnalytics::Return.cumulative)
colnames(rtn.daily) <- code
return(rtn.daily)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== rptDate related =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# -------------------- ~~ rptDate funcs ----------------
#' rptDate.is
#'
#' Is it a proper report date?
#' @param rptDate a vector of rptDate , with class Date.
#' @return a logical vector with the same length of rptDate.
#' @export
#' @author Ruifei.Yin
#' @seealso \code{\link{check.rptDate}}
#' @examples
#' rptDate.is(ymd(c(20100103,20141231,20130630)))
#' rptDate.is(ymd(c(20100630,20141231,20130930)))
#' rptDate.is(ymd(c(20100630,20141231,20130930)),"h")
rptDate.is <- function(rptDate,freq=c("q","y","h")){
freq <- match.arg(freq)
md <- 100*lubridate::month(rptDate) + lubridate::day(rptDate)
if(freq=="q"){
re <- md %in% c(331,630,930,1231)
} else if(freq=="h"){
re <- md %in% c(630,1231)
} else {
re <- md %in% c(1231)
}
return(re)
}
#' check.rptDate
#'
#' Is it a proper rptDate object? If TRUE, return NULL; else return an error.
#' @param rptDate a vector of rptDate , with class Date.
#' @export
#' @author Ruifei.Yin
#' @seealso \code{\link{rptDate.is}}
#' @examples
#' check.rptDate(ymd(c(20100103,20141231,20130630)))
#' check.rptDate(ymd(c(20100630,20141231,20130930)))
check.rptDate <- function(rptDate){
rptDate <- na.omit(rptDate) # omit the NA
re <- rptDate.is(rptDate)
re_all <- all(re)
if(!re_all) {
warning("rptDate is not proper report date!")
message("Following is not proper rptDate:")
print(rptDate[!re])
}
}
#' rptDate.yoy
#' @param rptDate a vector of rptDate , with class Date.
#' @return a vector of yoy rptDate.
#' @export
#' @author Ruifei.Yin
#' @examples
#' rptDate.yoy(lubridate::ymd(c(20100630,20141231,20130930)))
rptDate.yoy <- function(rptDate){
check.rptDate(rptDate)
re <- rptDate - lubridate::years(1)
re <- as.Date(re,tz="")
return(re)
}
#' rptDate.qoq
#' @param rptDate a vector of rptDate , with class Date.
#' @return a vector of qoq rptDate.
#' @export
#' @author Ruifei.Yin
#' @examples
#' rptDate.qoq(lubridate::ymd(c(20100630,20141231,20130930)))
rptDate.qoq <- function(rptDate){
check.rptDate(rptDate)
re <- rptDate %m-% months(3)
re <- lubridate::ceiling_date(re,unit="month") - lubridate::days(1)
re <- as.Date(re,tz="")
return(re)
}
#' rptDate.offset
#' @param rptDate a vector of rptDate , with class Date.
#' @param by a vector of integer
#' @param freq charactor string: "y" or "q".
#' @return a vector or a dataframe according to the length of rptDate and by.
#' @export
#' @author Ruifei.Yin
#' @examples
#' # multi rptDate and 1 by:
#' rptDate.offset(as.Date(c("2016-03-31","2016-06-30","2016-09-30")),-1,"q")
#' rptDate.qoq(as.Date(c("2016-03-31","2016-06-30","2016-09-30")))
#' rptDate.offset(as.Date(c("2016-03-31","2016-06-30","2016-09-30")),-1,"y")
#' rptDate.yoy(as.Date(c("2016-03-31","2016-06-30","2016-09-30")))
#' # 1 rptDate and multi by:
#' rptDate.offset(as.Date("2016-03-31"),-2:0,"q")
#' # multi rptDate and multi by:
#' rptDate.offset(as.Date(c("2016-03-31","2016-06-30","2016-09-30")),-2:0,"q")
rptDate.offset <- function(rptDate,by,freq){
check.rptDate(rptDate)
if(length(rptDate)>1 && length(by)>1){
for(i in 1:length(by)){
re_ <- rptDate.offset(rptDate = rptDate, by=by[i], freq=freq)
re_ <- data.frame(re_)
if(i==1L){
re <- re_
} else{
re <- cbind(re,re_)
}
}
colnames(re) <- paste(freq,by,sep = "")
} else {
if(freq=="y"){
re <- rptDate + lubridate::years(by)
}else if(freq=="q"){
re <- rptDate %m+% months(by*3)
re <- lubridate::ceiling_date(re,unit="month") - lubridate::days(1)
}else if(freq=="h"){
re <- rptDate %m+% months(by*6)
re <- lubridate::ceiling_date(re,unit="month") - lubridate::days(1)
}else{
stop("uncorrect freq!")
}
re <- as.Date(re,tz="")
}
return(re)
}
#' rptDate.deadline
#' return the deadline of rptDate.
#' @param rptDate a vector of rptDate, with class Date.
#' @return a vector of Date
#' @export
#' @author Ruifei.Yin
#' @examples
#' rptDate.deadline(ymd(c(20100630,20141231,20130930)))
rptDate.deadline <- function(rptDate){
check.rptDate(rptDate)
q <- lubridate::quarter(rptDate)
y <- lubridate::year(rptDate)
re <- ISOdate(y,4,30,tz="")
re[q==2] <- ISOdate(y[q==2], 8, 31, tz="")
re[q==3] <- ISOdate(y[q==3], 10, 31, tz="")
re[q==4] <- ISOdate(y[q==4]+1, 4, 30, tz="")
re <- as.Date(re,tz="")
return(re)
}
#' rptDate.yearrpt
#' @param datelist a vector of date , with class Date.
#' @return a vector of yearly rptDate.
#' @export
#' @author Ruifei.Yin
#' @examples
#' rptDate.nearest(as.Date(c("2015-01-11","2016-06-21","2016-12-31")),"q",1)
#' rptDate.nearest(as.Date(c("2015-01-11","2016-06-21","2016-12-31")),"y",-1)
rptDate.nearest <- function(datelist,freq=c("q","y","h"),dir=-1L){
freq <- match.arg(freq)
if(freq=="y"){
if(dir==-1L){
re <- dplyr::if_else(rptDate.is(datelist,freq = "y"),datelist,
lubridate::floor_date(datelist,unit="year") - lubridate::days(1))
} else {
re <- lubridate::ceiling_date(datelist,unit="year") - lubridate::days(1)
}
} else if(freq=="q"){
if(dir==-1L){
re <- dplyr::if_else(rptDate.is(datelist,freq = "q"),datelist,
lubridate::floor_date(datelist,unit="quarter") - lubridate::days(1))
} else {
re <- lubridate::ceiling_date(datelist,unit="quarter") - lubridate::days(1)
}
} else if(freq=="h"){
if(dir==-1L){
re <- dplyr::if_else(rptDate.is(datelist,freq = "h"),datelist,
lubridate::floor_date(datelist,unit="halfyear") - lubridate::days(1))
} else {
re <- lubridate::ceiling_date(datelist,unit="halfyear") - lubridate::days(1)
}
}
re <- as.Date(re,tz="")
return(re)
}
#' rptDate.yearrpt
#' @param freq "q","y","h"
#' @param dir 1L,-1L,or 0L
#' @return a vector of yearly rptDate.
#' @export
#' @author Ruifei.Yin
#' @examples
#' rptDate.get(as.Date("2011-02-06"),as.Date("2011-10-23"),freq="h",dir=1)
#' rptDate.get(as.Date("2011-12-31"),as.Date("2013-06-30"),freq="q",dir=0)
rptDate.get <- function(begT, endT, freq=c("q","y","h"), dir=0L){
freq <- match.arg(freq)
datelist <- c(seq(begT,endT,by='month'),endT)
if(dir==-1L){
re <- rptDate.nearest(datelist = datelist, freq = freq, dir = -1L)
}else if(dir==1L){
re <- rptDate.nearest(datelist = datelist, freq = freq, dir = 1L)
}else{
re <- rptDate.nearest(datelist = datelist, freq = freq, dir = -1L)
re <- re[re>=begT & re<=endT]
}
re <- unique(re)
return(re)
}
#' rptDate.publ
#'
#' @export
#' @author Aming.Tao
#' @examples
#' rptTS <- getrptTS(begT=as.Date("2016-02-06"),endT=as.Date("2017-8-23"),univ='EI000300')
#' re <- rptDate.publ(rptTS)
#' rptDate <- rptDate.get(as.Date("2011-02-06"),as.Date("2013-10-23"))
#' re <- rptDate.publ(rptDate=rptDate,stockID=c("EQ000001","EQ000002"))
rptDate.publ <- function(rptTS,rptDate,stockID,datasrc=defaultDataSRC()){
if (missing(rptTS) && any(missing(stockID),missing(rptDate))) {
stop("Param rptTS and combination of stockID and rptDate should at least have one!")
}
if (!missing(rptTS) && !all(missing(stockID),missing(rptDate))) {
stop("Param rptTS and combination of stockID and rptDate should only have one!")
}
if (missing(rptTS)){
rptTS <- expand.grid(rptDate=rptDate, stockID=stockID,stringsAsFactors = FALSE)
}
check.rptTS(rptTS)
if(datasrc=="quant"){
rptTS <- transform(rptTS,rptDate=rdate2int(rptDate))
con <- db.quant()
qr <- paste("select a.*,b.PublDate from temp_table a left join LC_RptDate b on a.stockID=b.stockID and a.rptDate=b.EndDate")
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=rptTS,tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
re <- transform(re,rptDate=intdate2r(rptDate))
}else if(datasrc=="local"){
rptTS <- transform(rptTS,rptDate=rdate2int(rptDate))
con <- db.local("main")
dbWriteTable(con,name="temp_table",value=rptTS,row.names = FALSE,overwrite = TRUE)
qr <- paste("select a.*,b.PublDate from temp_table a left join LC_RptDate b on a.stockID=b.stockID and a.rptDate=b.EndDate")
re <- dbGetQuery(con,qr)
dbDisconnect(con)
re <- transform(re,rptDate=intdate2r(rptDate))
}else if(datasrc=="ts"){
re <- rptTS.getFin_ts(rptTS,'"PublDate",report(128006,RDate)')
}
re <- transform(re,PublDate=intdate2r(PublDate))
return(re)
}
# -------------------- ~~ rptTS funcs ----------------
#' getrptTS
#' @param freq "q","y","h"
#' @param dir 1L,-1L,or 0L
#' @param univ a index or sector ID.
#' @return a \bold{rptTS} object.a dataframe,with cols:
#' \itemize{
#' \item date: the rptDates
#' \item stockID: the stockID
#' }.IF rptDates or stocks is not missing then use them directly, else get rptDates and stocks by \code{\link{rptDate.get}} and \code{\link{getComps}}.
#' @export
#' @author Ruifei.Yin
#' @examples
#' re1 <- getrptTS(begT=as.Date("2011-02-06"),endT=as.Date("2011-10-23"),univ="EI000300")
#' re2 <- getrptTS(rptDates=as.Date(c("2016-03-31","2016-09-30")),univ="EI000300")
#' re3 <- getrptTS(rptDates=as.Date(c("2016-03-31","2016-09-30")),stocks=c("EQ000001","EQ000002"))
#' re4 <- getrptTS(begT=as.Date("2011-02-06"),endT=as.Date("2011-10-23"),stocks=c("EQ000001","EQ000002"))
getrptTS <- function(begT,endT,freq=c("q","y","h"),dir=0,univ,
rptDates,stocks){
freq <- match.arg(freq)
if(missing(rptDates)){
rptDates <- rptDate.get(begT = begT, endT = endT, freq = freq, dir = dir)
}
check.rptDate(rptDates)
if(missing(stocks)){
re <- getComps(ID=univ,endT=rptDates,drop=FALSE)
re <- renameCol(re,"date","rptDate")
} else {
re <- expand.grid(rptDate=rptDates,stockID=stocks)
}
return(re)
}
#' rptTS.getFin
#'
#' get financtial indicators via \bold{rptTS} through WindR, or TinySoft.
#' @rdname rptTS.getFin
#' @name rptTS.getFin
#' @aliases rptTS.getFin_windR
#' @param rptTS a \bold{rptTS} object. a dataframe with cols:"rptDate","stockID"
#' @param field character strting or a vector of character string, giving the windfields. eg. "OPEN,CLOSE,HIGH" or c("OPEN","CLOSE","HIGH")
#' @param varname vector of charactor string
#' @param ... other arguments except \code{rptDate} in \code{w.wss}
#' @return a dataframe with the same length with rptTS, but added by some other financial indicator fields.
#' @export
#' @seealso \code{\link[WindR]{w.wss}}
#' @author Ruifei.Yin
#' @examples
#' rptTS <- getrptTS(begT=as.Date("2011-02-06"),endT=as.Date("2011-10-23"),stocks=c("EQ000001","EQ000002"))
#' # rptTS.getFin_windR
#' re <- rptTS.getFin_windR(rptTS,"np_belongto_parcomsh",options ="rptType=1")
rptTS.getFin_windR <- function(rptTS, field, varname, ...){
check.rptTS(rptTS)
require(WindR)
if(!w.isconnected()){
w.start(showmenu=FALSE)
}
rptTS2 <- transform(rptTS, stockID_wind=stockID2stockID(stockID,from="local",to="wind"), stringsAsFactors=FALSE)
Dts <- unique(rptTS$rptDate)
Dts <- na.omit(Dts)
df <- data.frame()
for(Dt in Dts){
Dt <- as.Date(Dt,origin = "1970-01-01")
codes <- rptTS2[rptTS2$rptDate==Dt, "stockID_wind", drop=TRUE]
w_out <- w.wss(codes=codes, fields=field, paste('rptDate=',rdate2int(Dt)), ...)
if(!w_out$ErrorCode==0){
stop(paste('Error in w.wss running! rptDate =',rdate2int(Dt),'; errorcode=',w_out$ErrorCode))
}
out <- data.frame(rptDate=Dt, w_out$Data)
if(dim(df)[1]==0) {
df <- out
} else {
df <- rbind(df,out)
}
}
df$stockID <- stockID2stockID(df$CODE,"wind","local")
re <- merge.x(rptTS,df,by=c("rptDate","stockID"))
re$CODE <- NULL
if(!missing(varname)){
re <- renameCol(re,setdiff(names(re),names(rptTS)), varname)
}
return(re)
}
#' @rdname rptTS.getFin
#' @param funchar expression to get variables from tinysoft,a character string, usually copyed from tinysoft "stock-data-expert" and then replace the specified reportdate in the stock-data-expert expression by \code{'Rdate'}. e.g. convert \code{Last12MData(20091231,46002)} to \code{Last12MData(Rdate,46002)}.
#' @note the funchar param could also be a 'multi_funchar', to get multi-factors. See details in the examples.
#' @param ... other arguments in \code{ts.wss}.
#' @export
#' @seealso \code{\link{ts.wss}}
#' @examples
#' # rptTS.getFin_ts
#' re2 <- rptTS.getFin_ts(rptTS,'"np_belongto_parcomsh",report(46078,RDate)')
#' multi_funchar <- '"eps",reportofall(9900000,RDate),
#' "zyywlrzzl",reportofall(9900601,RDate),
#' "yszk",report(44009,RDate)'
#' re3 <- rptTS.getFin_ts(rptTS,multi_funchar)
rptTS.getFin_ts <- function(rptTS, funchar,varname, ...){
check.rptTS(rptTS)
Dts <- unique(rptTS$rptDate)
Dts <- na.omit(Dts)
df <- data.frame()
for(Dt in Dts){
Dt <- as.Date(Dt,origin = "1970-01-01")
codes <- rptTS[rptTS$rptDate==Dt, "stockID", drop=TRUE]
ts_out <- ts.wss(stocks=codes, funchar=funchar,varname = varname, rptDate=Dt, adjust_yoy=TRUE, ...)
out <- data.frame(rptDate=Dt, ts_out)
if(dim(df)[1]==0) {
df <- out
} else {
df <- rbind(df,out)
}
}
re <- merge.x(rptTS,df,by=c("rptDate","stockID"))
re$stockName <- NULL
return(re)
}
#' @rdname rptTS.getFin
#' @export
#' @examples
#' # rptTS.getFinSeri_ts
#' FinSeri <- rptTS.getFinSeri_ts(rptTS,12,"q",'"np_belongto_parcomsh",report(46078,RDate)')
#' Finseri2 <- rptTS.getFinSeri_ts(rptTS,3,"y",multi_funchar)
rptTS.getFinSeri_ts <- function(rptTS, N, freq, funchar,varname, ...){
check.rptTS(rptTS)
# get rptTS_seri
rptDate_df <- rptDate.offset(rptTS$rptDate, by=-(N-1):0, freq = freq)
rptTS_seri <- cbind(rptTS[,c("stockID","rptDate")],rptDate_df)
rptTS_seri <- reshape2::melt(rptTS_seri,id.vars=c("stockID","rptDate"),variable.name="lagN",value.name="lag_rptDate")
# remove repdate before IPO
rptTS_seri$ipoDate <- trday.IPO(rptTS_seri$stockID)
rptTS_seri <- dplyr::filter(rptTS_seri,lag_rptDate>=ipoDate)
rptTS_seri <- dplyr::arrange(rptTS_seri,stockID,rptDate,desc(lag_rptDate))
# get the financial index data
rptTS_uniq <- unique(rptTS_seri[,c("stockID","lag_rptDate")])
rptTS_uniq <- renameCol(rptTS_uniq,"lag_rptDate","rptDate")
rptTS_uniq <- rptTS.getFin_ts(rptTS=rptTS_uniq,funchar=funchar, varname = varname, ...)
rptTS_uniq <- renameCol(rptTS_uniq,"rptDate","lag_rptDate")
re <- merge.x(rptTS_seri,rptTS_uniq,by =c("stockID","lag_rptDate"))
return(re)
}
#' calcFinStat
#'
#' @param fname this function can deal with multifactors. one can select which factors to calculate stat through fname param.
#' @export
#' @examples
#' # calcFinStat
#' FinStat <- calcFinStat(FinSeri,"mean")
calcFinStat <- function(FinSeri,stat=c('mean','sum','slope','slope/mean','slope/growthsd','sd','mean/sd'),fname,rm_N){
if(missing(fname)){
fname <- guess_factorNames(FinSeri,no_factorname = c("stockID", "rptDate","lagN","lag_rptDate","ipoDate"),is_factorname = "factorscore",silence = TRUE)
}
# melt & group_by
FinSeri <- reshape2::melt(FinSeri,measure.vars=fname,variable.name = "fname", value.name = "value")
FinSeri <- dplyr::group_by(FinSeri,fname,stockID,rptDate)
if(!missing(rm_N)){ # remove the too short seri
FinSeri <- FinSeri %>% dplyr::filter(n() > rm_N)
}
# get rptTS_stat
if(stat=="mean"){
rptTS_stat <- dplyr::summarise(FinSeri,value=mean(value,na.rm = TRUE))
} else if (stat=="sum"){
rptTS_stat <- dplyr::summarise(FinSeri,value=sum(value,na.rm = TRUE))
} else if (stat=="sd"){
rptTS_stat <- dplyr::summarise(FinSeri,value=sd(value,na.rm = TRUE))
} else if (stat=="mean/sd"){
rptTS_stat <- dplyr::summarise(FinSeri,value=mean(value,na.rm = TRUE)/sd(value,na.rm = TRUE))
} else if (stat %in% c("slope","slope/mean","slope/growthsd")){
FinSeri$lagN <- as.integer(substr(FinSeri$lagN,2,1000))
if(stat=="slope"){
rptTS_stat <- dplyr::do(FinSeri,mod = lm(value ~ lagN, data = .))
rptTS_stat <- broom::tidy(rptTS_stat,mod)
rptTS_stat <- rptTS_stat[rptTS_stat$term=='lagN',c("fname","stockID","rptDate","estimate")]
rptTS_stat <- renameCol(rptTS_stat,"estimate","value")
}else if(stat %in% c("slope/mean","slope/growthsd")){
if(stat=="slope/mean"){
rptTS_stat1 <- FinSeri %>% dplyr::summarise(value2=mean(value,na.rm = TRUE))
}else{
FinSeri <- FinSeri %>% dplyr::mutate(value2=value/dplyr::lead(value)-1)
FinSeri <- FinSeri %>% dplyr::filter(!is.na(value2))
rptTS_stat1 <- dplyr::summarise(FinSeri,value2=sd(value2,na.rm = TRUE))
}
rptTS_stat2 <- dplyr::do(FinSeri,mod = lm(value ~ lagN, data = .))
rptTS_stat2 <- broom::tidy(rptTS_stat2,mod)
rptTS_stat2 <- rptTS_stat2[rptTS_stat2$term=='lagN',c("fname","stockID","rptDate","estimate")]
rptTS_stat <- dplyr::left_join(rptTS_stat1,rptTS_stat2,by=c("fname","stockID","rptDate"))
rptTS_stat <- transform(rptTS_stat,value=estimate/value2,estimate=NULL,value2=NULL)
}
}
# cast
re <- reshape2::dcast(rptTS_stat,stockID+rptDate~fname)
return(re)
}
#' rptTS.getFinStat_ts
#'
#' @export
#' @examples
#' # rptTS.getFinStat_ts
#' FinStat <- rptTS.getFinStat_ts(rptTS,12,"q",'"np_belongto_parcomsh",report(46078,RDate)',stat="mean")
rptTS.getFinStat_ts <- function(rptTS, N, freq, funchar, varname,
stat=c('mean','sum','slope','slope/mean','slope/growthsd','sd','mean/sd'),
rm_N, ...){
stat <- match.arg(stat)
check.rptTS(rptTS)
FinSeri <- rptTS.getFinSeri_ts(rptTS = rptTS,N = N,freq = freq,funchar = funchar, varname = varname, ...)
rptTS_stat <- calcFinStat(FinSeri=FinSeri,stat = stat,fname = varname, rm_N = rm_N)
re <- merge.x(rptTS,rptTS_stat,by=c("stockID","rptDate"))
return(re)
}
# -------------------- ~~ TS.getFin_by_rptTS ----------------
#' getrptDate_newest
#'
#' get the newest rptDate of the stocks on specific dates.
#' @param TS a \bold{TS} object
#' @param stockID a vector of stockID
#' @param endT a vector of Date
#' @param mult a character string. Could be one of "last","first","all". IF a listed company publish more than one financial reports in a single day, which one should be returned? the newest one(the default value), the earliest one or all of them? See example for dedail.
#' @param drop a logical. Shoud the \code{TS} be exculded in the result?
#' @return a data.frame,with the same cols of TS,added by "\code{rptDate}". Or a vector if \code{drop} is TRUE.
#' @note param TS and combination of stockID and endT should at least have one and only have one. The combination of vector stockID and endT could be different length, which abide by the recycling rule.
#' @author Ruifei.Yin
#' @export
#' @examples
#' # - with TS
#' TS <- getTS(getRebDates(as.Date('2007-03-17'),as.Date('2012-05-20'),rebFreq="year"),'EI000300')
#' getrptDate_newest(TS)
#' # - one stock, multiple dates
#' getrptDate_newest(stockID="EQ000001", endT=seq(from=as.Date("2010-12-31"),to=as.Date("2011-12-31"),by="month"))
#' # - one date, multiple stocks
#' getrptDate_newest(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2003-04-30"))
#' # - multi="all"
#' getrptDate_newest(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2003-04-30"),mult="all")
#' # - multi="first"
#' getrptDate_newest(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2003-04-30"),mult="first")
getrptDate_newest <- function(TS,stockID,endT=Sys.Date(),freq=c("q","y","h"),
mult=c("last","first","all"),
drop=FALSE,
datasrc=defaultDataSRC()){
freq <- match.arg(freq)
mult <- match.arg(mult)
if (missing(TS) && missing(stockID)) {
stop("Param TS and combination of stockID and endT should at least have one!")
}
if (!missing(TS) && !missing(stockID)) {
stop("Param TS and combination of stockID and endT should only have one!")
}
if (missing(TS)){
TS <- data.frame(date=endT, stockID=stockID)
}
check.TS(TS)
if(datasrc %in% c("quant","local")){
TS_new <- TS
TS_new$date <- rdate2int(TS_new$date)
if(datasrc=="quant"){
qr <- "select a.date,a.stockID,
(select top 1 EndDate from LC_RptDate where stockID=a.stockID and PublDate<=a.date order by EndDate Desc ) as rptDate
from temp_table a"
con <- db.quant()
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=TS_new[,c("date","stockID")],tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr,stringsAsFactors=FALSE)
odbcClose(con)
} else if (datasrc=="local"){
qr <- "select a.date,a.stockID,
(select EndDate from LC_RptDate where stockID=a.stockID and PublDate<=a.date order by EndDate Desc limit 1) as rptDate
from temp_table a"
con <- db.local("main")
dbWriteTable(con,name="temp_table",value=TS_new[,c("date","stockID")],row.names = FALSE,overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re <- transform(re, date=intdate2r(date), rptDate=intdate2r(rptDate))
}else if(datasrc=='ts'){
dates <- unique(TS$date)
re <- data.frame(stringsAsFactors = FALSE)
for(i in 1:length(dates)){
TS_ <- TS[TS$date==dates[i],]
tsdate <- rdate2ts(dates[i])
funchar <- paste("'rptDate',NewReportDateOfEndT2(",tsdate,")",sep = '')
re_ <- ts.wss(TS_$stockID,funchar=funchar)
re_ <- re_ %>% dplyr::mutate(date=dates[i],rptDate=intdate2r(rptDate)) %>% dplyr::select(date,stockID,rptDate)
re <- rbind(re,re_)
}
}
if(freq %in% c("y","h")){ # get the newest yearly report or halfyearly report
re$rptDate <- rptDate.nearest(re$rptDate,freq = freq,dir = -1L)
}
re <- merge.x(TS,re,by=c("date","stockID"),mult=mult)
if(drop){
return(re[,"reptDate"])
} else {
return(re)
}
}
#' TS.getFin_by_rptTS
#'
#' get financial factorscore via rptTS
#' @param fun a function or a non-empty character string naming the function to be called, which get the financtial indicators from \bold{rptTS}. Note that the function must contain a param of 'rptTS' .
#' @param ... optional arguments except rptTS of fun.
#' @return a dataframe with the same length with TS, but added by some other financial indicator fields.
#' @export
#' @seealso \code{\link{rptTS.getFin_windR}}, \code{\link{rptTS.getFin_ts}}
#' @author Ruifei.Yin
#' @examples
#' TS <- Model.TS(modelPar.univ(indexID="ES09440000"))
#' re <- TS.getFin_by_rptTS(TS,fun="rptTS.getFin_windR",field="np_belongto_parcomsh","rptType=1")
#' re2 <- TS.getFin_by_rptTS(TS,fun="rptTS.getFin_ts",funchar='"np_belongto_parcomsh",report(46078,RDate)')
#' # -- Following is a speed comparison of three different methods to get financial factorscores:
#'
#' TS <- Model.TS(setmodelPar.time(modelPar.default(),begT=as.Date("2007-12-01"),endT=as.Date("2014-05-01")))
#' system.time(re.wind <- TS.getFin_by_rptTS(TS,fun="rptTS.getFin_windR",field="np_belongto_parcomsh","rptType=1")) # 73.69
#' system.time(re.ts_dir <- TS.getFin_ts(TS,funchar='report(46078,RDate)',varname="np_belongto_parcomsh")) # 12.49
#' system.time(re.ts_rpt <- TS.getFin_by_rptTS(TS,fun="rptTS.getFin_ts",funchar='"np_belongto_parcomsh",report(46078,RDate)')) # 6.29
TS.getFin_by_rptTS <- function(TS, fun, ...){
check.TS(TS)
TS <- getrptDate_newest(TS,mult="last")
rptTS <- unique(TS[, c("rptDate","stockID")])
rptTSF <- do.call(fun, list(rptTS=rptTS, ...))
TSF <- merge.x(TS, rptTSF, by=c("rptDate","stockID"))
return(TSF)
}
# -------------------- ~~ TSFR.rptTSF_nextF ----------------
#' TSFR.rptTSF_nextF
#'
#' @param funchar a tinysoft financial factor function string. Can be missing when ... arguments are passed, in this case, any 'gf.xx' function(not only financial factors) could be tested.
#' @param ... argument for \code{\link[QDataGet]{getTSF}}.
#' @return a \bold{TSFR} object,\code{date_end} represents next report date,\code{factorscore} represents factorscore of next report date.
#' @examples
#' begT <- as.Date("2007-12-31")
#' endT <- as.Date("2017-12-31")
#' univ <- "EI000985"
#' #- freq="y"
#' funchar <- '"factorscore",reportofall(9900100,RDate)' #ROE
#' funchar <- '"factorscore",reportofall(9900604,RDate)' #growth of net profit
#' funchar <- '"factorscore",reportofall(9900501,RDate)' #divdendyield
#' refinePar <- refinePar_default("none")
#' refinePar <- refinePar_default("scale_sec")
#' TSFR <- TSFR.rptTSF_nextF(begT,endT,freq="y",univ,funchar,refinePar)
#' #- freq="q"
#' funchar <- '"factorscore",LastQuarterData(RDate,9900604)'
#' TSFR <- TSFR.rptTSF_nextF(begT,endT,freq="q",univ,funchar,refinePar=refinePar_default("reg"))
#' #- funchar is missing
#' TSFR <- TSFR.rptTSF_nextF(begT,endT,freq="y",univ,factorFun='gf.PB_mrq', factorPar = list(fillna = TRUE))
#' @export
TSFR.rptTSF_nextF <- function(begT=as.Date("2007-12-31"),endT=as.Date("2016-12-31"),
freq='y',univ,funchar,refinePar=refinePar_default(),...){
#get report TS
rptDates <- rptDate.get(begT,endT,freq)
rptTS <- getrptTS(univ=univ,rptDates=rptDates)
rptTS <- rptDate.publ(rptTS)
rptTS <- rptTS %>% dplyr::filter(!is.na(PublDate)) %>% dplyr::select(-PublDate)
#get report TSF and refine
if(missing(funchar)){
TS <- rptTS %>% dplyr::rename(date=rptDate)
rptTSF <- getTSF(TS,...)
rptTSF <- rptTSF %>% dplyr::rename(rptDate=date)
}else{
rptTSF <- rptTS.getFin_ts(rptTS,funchar)
}
TSF <- rptTSF %>% dplyr::rename(date=rptDate)
TSF <- factor_refine(TSF,refinePar)
TSF <- TSF %>% dplyr::filter(!is.na(factorscore))
#get next period factorscore and refine
rptTS_ <- transform(rptTS,rptDate_end=rptDate.offset(rptDate,1,freq))
rptTS2 <- rptTS_ %>% dplyr::select(rptDate_end,stockID) %>%
dplyr::rename(rptDate=rptDate_end) %>% dplyr::setdiff(rptTS)
if(nrow(rptTS2)>0){
rptTS2 <- rptDate.publ(rptTS2)
rptTS2 <- rptTS2 %>% dplyr::filter(!is.na(PublDate)) %>% dplyr::select(-PublDate)
if(missing(funchar)){
TS2 <- rptTS2 %>% dplyr::rename(date=rptDate)
rptTSF2 <- getTSF(TS2,...)
rptTSF2 <- rptTSF2 %>% dplyr::rename(rptDate=date)
}else{
rptTSF2 <- rptTS.getFin_ts(rptTS2,funchar)
}
rptTSF <- rbind(rptTSF,rptTSF2)
}
TSF2 <- rptTSF %>% dplyr::arrange(rptDate,stockID) %>% dplyr::rename(date=rptDate)
TSF2 <- factor_refine(TSF2,refinePar)
TSF2 <- TSF2 %>% dplyr::filter(!is.na(factorscore)) %>% dplyr::rename(date_end=date,periodrtn=factorscore)
#get TSFR
rptTS_ <- rptTS_ %>% dplyr::rename(date=rptDate,date_end=rptDate_end)
TSFR <- TSF %>% dplyr::left_join(rptTS_,by=c('date','stockID')) %>%
dplyr::left_join(TSF2,by=c('date_end','stockID'))
return(TSFR)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== Others =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' getTech
#'
#' @export
#' @rdname getTech
getTech <- function(TS,
variables = select.list(CT_TechVars(datasrc=datasrc,secuCate="EQ",tableName=tableName)[["varName"]],graphics=TRUE,multiple=TRUE),
tableName="QT_DailyQuote",
datelist,stockID,
drop,
datasrc=defaultDataSRC()){
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
missing_TS <- TRUE
} else {
missing_TS <- FALSE
}
re <- TS.getTech(TS=TS,variables = variables,tableName = tableName,datasrc = datasrc)
if(missing(drop)){
drop <- if(missing_TS&length(variables)==1) TRUE else FALSE
}
if(drop){
return(re[,variables])
}else{
return(re)
}
}
#' @rdname getTech
#' @export
TS.getTech <- function(TS,
variables = select.list(CT_TechVars(datasrc=datasrc,secuCate="EQ",tableName=tableName)[["varName"]],graphics=TRUE,multiple=TRUE),
tableName="QT_DailyQuote",
datasrc=defaultDataSRC()){
check.TS(TS)
tmpdat <- transform(TS[,c("stockID","date")], date = rdate2int(date))
tmpdat$PK_ <- 1:NROW(tmpdat)
vars <- CT_TechVars(datasrc=datasrc,secuCate="EQ",tableName=tableName,vars=variables)
if(NROW(vars)==0){
stop(paste("No fields matched in table",QT(tableName),"in datasrc",QT(datasrc),"!"))
}
vars <- paste(vars$func,"as",QT(vars$varName), collapse=", ")
qr <- paste("select a.*,",vars,"from temp_table a left join",tableName ,"b on a.stockID=b.ID and a.date=b.TradingDay")
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=tmpdat,tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- if(tableName =="QT_FactorScore"){
db.local("fs")
}else if(tableName =="QT_FactorScore_R"){
db.local("fs_r")
}else{
db.local("qt")
}
dbWriteTable(con,name="temp_table",value=tmpdat,row.names = FALSE,overwrite = TRUE)
if(tableName %in% c("QT_DailyQuote","QT_FactorScore","QT_FactorScore_R")){
dbExecute(con, 'CREATE INDEX [IX_temp_table] ON [temp_table]([date],[stockID]);')
}
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re <- dplyr::arrange(re,PK_)[,variables,drop=FALSE]
re <- cbind(TS,re)
return(re)
}
#' @export
#' @rdname getTech_ts
getTech_ts <- function(TS,funchar,varname=funchar, Rate=1, RateDay=0,
datelist,stockID,
drop){
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if(missing(drop)){
drop <- if(missing(TS)&length(funchar)==1) TRUE else FALSE
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
result <- TS.getTech_ts(TS=TS,funchar = funchar,varname = varname,Rate = Rate,RateDay = RateDay)
if(drop){
return(result[,varname])
}else{
return(result)
}
}
#' getTech_ts
#'
#' get technical factors throug a tinysoft expression, which could be a simple expresion, e.g 'close()','StockZf2(20)','BBIBOLL_v(11,6)',..,or more complicated expression, e.g. 'close()/open()', 'StockZf2(10)-StockZf2(20)'...
#' @param TS a \bold{TS} object
#' @param funchar a vector of character,the tinysoft function with the arguments. e.g \code{"BBIBOLL_v(11,6)"}
#' @param varname character string, giving the name of the returned variables
#' @return A \bold{TSF} object
#' @note Note that the tinysoft function must contain ONLY two(no more!) system parameters: pn_stock() and pn_date() ,which is specifyed by the two fields in the TS respectively.
#' @author Ruifei.Yin
#' @export
#' @rdname getTech_ts
#' @examples
#' TS <- getTS(getRebDates(as.Date('2011-03-17'),as.Date('2012-04-17')),'EI000300')
#' p1 <- 11
#' p2 <- 6
#' funchar <- paste('BBIBOLL_v(',p1,',',p2,')',sep='')
#' TSF <- TS.getTech_ts(TS,funchar)
#' TSF <- TS.getTech_ts(TS, funchar="StockAveHsl2(20)/StockAveHsl2(60)", varname="avgTurnover_1M3M")
#' funchar <- c('BBIBOLL_v(11,6)','StockAveHsl2(20)/StockAveHsl2(60)')
#' TSF2 <- TS.getTech_ts(TS, funchar)
TS.getTech_ts <- function(TS,funchar,varname=funchar, Rate=1, RateDay=0){
check.TS(TS)
tmpfile <- TS[,c('date','stockID')]
tmpfile$stockID <- stockID2stockID(tmpfile$stockID,from="local",to="ts")
tmpfile$date <- as.character(tmpfile$date)
tmpcsv <- tempfile(fileext=".csv")
tmpcsv2 <- stringr::str_replace_all(tmpcsv,'\\\\',"\\\\\\\\")
write.csv(tmpfile,tmpcsv,row.names=FALSE,quote=FALSE)
subqr <- ""
for( i in 1:length(funchar)){
subqr <- paste0(subqr, ' factorexp[',i-1,'] := &"',funchar[i],'"; ')
}
subqr2 <- ""
if(!is.null(Rate)){
subqr2 <- paste0(subqr2, ' SetSysParam(pn_rate(), ',Rate,'); ')
}
if(!is.null(RateDay)){
subqr2 <- paste0(subqr2, ' SetSysParam(pn_rateday(), ',RateDay,'); ')
}
len.funchar <- length(funchar)-1
qrstr <- paste0('oV:=BackUpSystemParameters();
SetSysParam(pn_cycle(),cy_day());
',subqr2,'
rdo2 importfile(ftcsv(),"","',tmpcsv2,'",timestockframe);
factorexp := array();
',subqr,'
result:=array();
for i:=0 to length(timestockframe)-1 do
begin
SetSysParam(pn_stock(),timestockframe[i]["stockID"]);
SetSysParam(pn_date(),strtodate(timestockframe[i]["date"]));
for j:= 0 to ',len.funchar,' do
begin
factorvalue:=eval(factorexp[j]);
result[i][j]:=factorvalue;
end;
end;
RestoreSystemParameters(oV);
return result;')
tsRequire()
fct <- tsRemoteExecute(qrstr)
fct <- plyr::ldply(fct, unlist)
colnames(fct) <- varname
result <- cbind(TS,fct)
return(result)
}
#' @export
#' @rdname getFin_ts
getFin_ts <- function(TS,funchar,varname=funchar,Rate=1,RateDay=0,
datelist,stockID,
drop){
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if(missing(drop)){
drop <- if(missing(TS)&length(funchar)==1) TRUE else FALSE
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
result <- TS.getFin_ts(TS=TS,funchar = funchar,varname = varname,Rate = Rate,RateDay = RateDay)
if(drop){
return(result[,varname])
}else{
return(result)
}
}
#' getFin_ts
#'
#' get financial factors throug a tinysoft expression, which could be simple or more complicated.
#'
#' Note that the tinysoft function must contain ONLY two system parameters(no more!):pn_stock() and pn_date() ,which is supplyed from the two fields in the TS respectively.Also,the function must contain a expression of 'Rdate:=NewReportDateOfEndT2(sp_time())' to get the newest Rdate of sp_time.
#' @param TS a \bold{TS} object
#' @param funchar a vector of character string, giving a tinysoft expression to get the financtial indicators of the stock. The expression can be made simply by replaceing the specified reportdate in the stock-data-expert expression by \code{'Rdate'}. e.g. change \code{Last12MData(20091231,46002)} to \code{Last12MData(Rdate,46002)}.
#' @param varname character string, giving the name of the returned variables
#' @return A \bold{TSF} object,a dataframe, containing at least cols:\bold{date}(with class of Date),\bold{stockID},\bold{varname},\bold{Rdate}
#' @note Note that the tinysoft function must contain ONLY two system parameters(no more!):pn_stock() and pn_date() ,which is supplyed from the two fields in the TS respectively. Also,the function must contain a expression of 'Rdate:=NewReportDateOfEndT2(sp_time())' to get the newest Rdate of sp_time.
#' @author Ruifei.Yin
#' @export
#' @rdname getFin_ts
#' @examples
#' TS <- getTS(getRebDates(as.Date('2011-03-17'),as.Date('2012-04-17')),'EI000300')
#' TSF <- TS.getFin_ts(TS,"ReportOfAll(9900416,Rdate)")
#' TSF2 <- TS.getFin_ts(TS,"GrowthOfNReport(@@LastQuarterData(DefaultRepID(),9900003,0),Rdate,3,1)")
#' TSF3 <- TS.getFin_ts(TS,"StockAveHsl2(20)+reportofall(9900003,Rdate)")
#' funchar <- c("ReportOfAll(9900416,Rdate)","StockAveHsl2(20)+reportofall(9900003,Rdate)")
#' TSF4 <- TS.getFin_ts(TS, funchar)
TS.getFin_ts <- function(TS,funchar,varname=funchar,Rate=1,RateDay=0){
check.TS(TS)
tmpfile <- TS[,c('date','stockID')]
tmpfile$stockID <- stockID2stockID(tmpfile$stockID,from="local",to="ts")
tmpfile$date <- as.character(tmpfile$date)
tmpcsv <- tempfile(fileext=".csv")
tmpcsv2 <- stringr::str_replace_all(tmpcsv,'\\\\',"\\\\\\\\")
write.csv(tmpfile,tmpcsv,row.names=FALSE,quote=FALSE)
subqr <- ""
for( i in 1:length(funchar)){
subqr <- paste0(subqr, ' factorexp[',i-1,'] := &"',funchar[i],'"; ')
}
subqr2 <- ""
if(!is.null(Rate)){
subqr2 <- paste0(subqr2, ' SetSysParam(pn_rate(), ',Rate,'); ')
}
if(!is.null(RateDay)){
subqr2 <- paste0(subqr2, ' SetSysParam(pn_rateday(), ',RateDay,'); ')
}
len.funchar <- length(funchar)-1
qrstr <- paste0('oV:=BackUpSystemParameters();
SetSysParam(pn_cycle(),cy_day());
',subqr2,'
rdo2 importfile(ftcsv(),"","',tmpcsv2,'",timestockframe);
factorexp := array();
',subqr,'
result:=array();
for i:=0 to length(timestockframe)-1 do
begin
SetSysParam(pn_stock(),timestockframe[i]["stockID"]);
SetSysParam(pn_date(),strtodate(timestockframe[i]["date"]));
Rdate:=NewReportDateOfEndT2(sp_time());
for j:=0 to ',len.funchar,' do
begin
factorvalue:=eval(factorexp[j]);
result[i][j]:=factorvalue;
end;
result[i]["Rdate"]:=Rdate;
end;
RestoreSystemParameters(oV);
return result;')
tsRequire()
fct <- tsRemoteExecute(qrstr)
fct <- plyr::ldply(fct,as.data.frame)
colnames(fct) <- c(varname, "RDate")
result <- cbind(TS,fct)
return(result)
}
#' getQuote_ts
#'
#' get Quote series of some stocks in certain period
#' @param stocks a vector of charactor
#' @param begT an object of class "Date"
#' @param endT an object of class "Date"
#' @param variables a vector of charactor,elements of which could be stockID,stockName,date,price,open,high,low,vol,amount,yclose,sectional_yclose,cjbs,...
#' @param Cycle a charactor string,eg."cy_day()","cy_30m()","cy_month()",...
#' @param Rate a integer,giving the type of rights adjustment, could be one of 0(no adjustment),1(geometric adjustment),2(simple adjustment),3
#' @param RateDay a integer,giving the base date of right adjustment,could be one of 0(the last trading day),-1(the IPO date),or a tinysoft date integer(eg.\code{rdate2ts(as.Date("2010-01-02"))})
#' @param melt a logical. If FALSE(default), the style of result is "stockID+date~variable";If TRUE, the quote data will be melted(see the examples for details).
#' @param split logical.
#' @param splitNbin integer.
#' @return the quote data, a data frame object with cols:stockID,stockName,date(\bold{of class POSIXct}) and the elements the param \code{variable} containing
#' @export
#' @author Ruifei.Yin
#' @examples
#' stocks <- c("SZ002001","SZ002002")
#' begT <- as.Date("2011-01-01")
#' endT <- as.Date("2011-02-01")
#' variables <- c("price","open")
#' qt.asis <- getQuote_ts(stocks,begT,endT,variables)
#' qt.melt <- getQuote_ts(stocks,begT,endT,variables,melt=TRUE)
getQuote_ts <- function(stocks,begT,endT,variables,Cycle="cy_day()",Rate=0,RateDay=0,melt=FALSE,
split = if(length(stocks) > splitNbin) TRUE else FALSE,
splitNbin = 50){
# stocks <- c("SZ002001","SZ002002")
# begT <- as.Date("2008-01-01")
# endT <- as.Date("2011-02-01")
# variables <- c("price","yclose")
# Cycle="cy_day()"
# Rate=0
# RateDay=0
subfun <- function(stocks,begT,endT,variables,Cycle,Rate,RateDay,melt){
stockID <- paste(stocks,collapse=",")
begT <- rdate2ts(begT)
endT <- rdate2ts(endT)
variables <- paste('["',variables,'"]',sep="",collapse=",")
tsRequire()
qt <- tsRemoteCallFunc("getQuote",list(stockID,begT,endT,variables,Cycle,Rate,RateDay))
qt <- plyr::ldply(qt,as.data.frame)
qt$date <- as.POSIXct(qt$date,tz="")
if(melt){
qt <- reshape2::melt(qt,id.vars=c("stockID","date"))
}
return(qt)
}
if(!split){
re <- subfun(stocks,begT,endT,variables,Cycle,Rate,RateDay,melt)
} else {
Ngroup <- length(stocks) %/% splitNbin +1
Ngroup <- if(Ngroup>1) Ngroup else Ngroup+1
bby <- cut(1:length(stocks),Ngroup,labels=FALSE)
warning(paste('Possibly dealing with a big quote data. The process is split to ',Ngroup,'groups.'))
for(i in 1:Ngroup){
# i <- 2
substocks <- stocks[bby==i]
message("Dealing with ",i," of ",Ngroup,"groups ... ")
gc()
qt <- subfun(substocks,begT,endT,variables,Cycle,Rate,RateDay,melt)
if(i==1L){
re <- qt
} else {
re <- rbind(re,qt)
}
}
}
return(re)
}
#' getQuote
#'
#' get Quote series of stocks, indexs, futures in certain period
#' @aliases getQuote getIndexQuote getIFquote
#' @param stocks a charactor vector of stockID or indexID.
#' @param begT an object of class "Date"
#' @param endT an object of class "Date"
#' @param variables a vector of charactor. Call funtion \code{CT_TechVars(secuCate="EQ")} to get all available variables of equity, funtion \code{CT_TechVars(secuCate="EI")} of equity index, and funtion \code{CT_TechVars(secuCate="IF")} of index future.
#' @param melt a logical. If FALSE(default), the style of result is "stockID+date~variable";If TRUE, the quote data will be melted(see the examples for details).
#' @param split logical
#' @param splitNbin an interval specification, one of "day", "week", "month", "quarter" and "year", optionally preceded by an integer and a space, or followed by "s". See \code{\link{cut.Date}} for detail.
#' @param tableName character string, giving the table name from which get data.
#' @return the quote data, a data frame object with cols:stockID,date and the elements the param \code{variable} containing. If melt is TRUE, data frame with cols:stockID,date,variable,value
#' @export
#' @author Ruifei.Yin
#' @examples
#' # get stock's quote
#' stocks <- c("EQ002001","EQ002002")
#' begT <- as.Date("2007-01-01")
#' endT <- as.Date("2013-02-01")
#' variables <- c("close","pct_chg","vwap")
#' re <- getQuote(stocks,begT,endT,variables,datasrc="local")
#' re <- getQuote(stocks,begT,endT,variables,melt=TRUE,datasrc="local")
#' stocks <- getIndexComp("EI000300")
#' system.time(uu2 <- getQuote(stocks,begT,endT,variables,datasrc="local",split=FALSE))
#' system.time(uu1 <- getQuote(stocks,begT,endT,variables,datasrc="local",split=TRUE))
getQuote <- function(stocks, begT=as.Date("1990-12-19"), endT=Sys.Date(),
variables = select.list(CT_TechVars(datasrc=datasrc,secuCate="EQ",tableName=tableName)[["varName"]],graphics=TRUE,multiple=TRUE),
melt=FALSE,
split,
splitNbin = 'year',
tableName = "QT_DailyQuote",
datasrc=defaultDataSRC()){
if(begT>endT){
stop(paste("begT ",begT,"is later then endT ",endT))
}
techVars <- CT_TechVars(datasrc=datasrc,secuCate="EQ",tableName=tableName,vars=variables)
if(NROW(techVars)==0){
stop(paste("No fields matched in ",tableName," in datasrc",QT(datasrc),"!"))
}
vars_as <- paste(techVars$func,"as",QT(techVars$varName), collapse=", ")
vars_new <- paste(techVars$varName,collapse=",")
dates <- data.frame(date=getRebDates(begT,endT,rebFreq = 'day'))
dates <- dates %>% dplyr::filter(date>=begT,date<=endT) %>%
dplyr::mutate(splitday=as.Date(cut.Date2(date,splitNbin)),date=rdate2int(date))
splitdays <- unique(dates$splitday)
if(missing(split)){
if(length(splitdays)>1){
split <- TRUE
}else{
split <- FALSE
}
}
stockdf <- data.frame(stockID=stocks,stringsAsFactors = FALSE)
stockdf <- stockdf %>% dplyr::mutate(InnerCode=stockID2stockID(stockID,from = 'local',to = 'jy'),
ipoday=rdate2int(trday.IPO(stockID)))
ts <- expand.grid(date=dates$date,InnerCode=stockdf$InnerCode, KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE)
ts <- ts %>% dplyr::left_join(stockdf,by='InnerCode') %>%
dplyr::filter(date>=ipoday) %>%
dplyr::select(-ipoday)
if(datasrc=='local'){
con <- db.local("qt")
subfun_local <- function(TS,melt){
dbWriteTable(con,name="temp_table",value=TS,row.names = FALSE,overwrite = TRUE)
dbExecute(con, 'CREATE INDEX [IX_temp_table] ON [temp_table] ([date],[InnerCode]);')
querychar <- paste("select a.stockID,a.date,",vars_new,"from temp_table a inner join
(select TradingDay,InnerCode,",vars_as,
"from ",tableName," where TradingDay>=",min(TS$date)," and TradingDay<=",max(TS$date),") b
on a.date=b.TradingDay and a.InnerCode=b.InnerCode")
qt <- dbGetQuery(con,querychar)
qt$date <- intdate2r(qt$date)
if(melt){
qt <- reshape2::melt(qt,id.vars=c("stockID","date"))
}
return(qt)
}
if(!split){
re <- subfun_local(ts,melt)
}else{
ts <- ts %>% dplyr::left_join(dates,by='date')
warning(paste('Possibly dealing with a big data. The process is splited to ',length(splitdays),'groups.'))
re <- data.frame(stringsAsFactors = FALSE)
for(i in 1:length(splitdays)){
ts_ <- ts %>% dplyr::filter(splitday==splitdays[i]) %>% dplyr::select(-splitday)
cat("Dealing with ",i," of ",length(splitdays),"groups ... \n")
gc()
re_ <- subfun_local(ts_,melt)
re <- rbind(re,re_)
}
}
dbDisconnect(con)
}else if(datasrc=="quant"){
con <- db.quant()
subfun_quant <- function(stockID,begT,endT,melt){
querychar <- paste("select ID as stockID,TradingDay as date,",vars_as,
"from ",tableName," where ID in",
brkQT(stockID)," and TradingDay >=", begT, " and TradingDay <=",endT)
qt <- sqlQuery(con,querychar,as.is=FALSE,stringsAsFactors = FALSE)
qt$date <- intdate2r(qt$date)
if(melt){
qt <- reshape2::melt(qt,id.vars=c("stockID","date"))
}
return(qt)
}
if(!split){
re <- subfun_quant(stockdf$stockID,rdate2int(begT),rdate2int(endT),melt)
}else{
ts <- ts %>% dplyr::left_join(dates,by='date')
warning(paste('Possibly dealing with a big data. The process is splited to ',length(splitdays),'groups.'))
re <- data.frame(stringsAsFactors = FALSE)
for(i in 1:length(splitdays)){
ts_ <- ts %>% dplyr::filter(splitday==splitdays[i]) %>% dplyr::select(-splitday)
cat("Dealing with ",i," of ",length(splitdays),"groups ... \n")
gc()
re_ <- subfun_quant(stockdf$stockID,min(ts_$date),max(ts_$date),melt)
re <- rbind(re,re_)
}
}
re <- dplyr::arrange(re,date,stockID)
odbcClose(con)
}
return(re)
}
#' @rdname getQuote
#' @export
#' @examples
#' # get index quote
#' indexs <- c("EI000001","EI000300")
#' begT <- as.Date("2015-01-01")
#' endT <- as.Date("2016-08-01")
#' variables <- c("close","pct_chg")
#' re <- getIndexQuote(indexs,begT,endT,variables,datasrc="local")
#' re <- getIndexQuote(indexs,begT,endT,variables,datasrc="jy")
getIndexQuote <- function(stocks,
begT=as.Date("1990-12-19"), endT=Sys.Date(),
variables = select.list(CT_TechVars(datasrc=datasrc,secuCate="EI",tableName="QT_IndexQuote")[["varName"]],graphics=TRUE,multiple=TRUE),
melt=FALSE,
datasrc=defaultDataSRC()){
begT <- rdate2int(begT)
endT <- rdate2int(endT)
vars <- CT_TechVars(datasrc=datasrc,secuCate="EI",tableName="QT_IndexQuote",vars=variables)
if(NROW(vars)==0){
stop(paste("No fields matched in table 'QT_IndexQuote' in datasrc",QT(datasrc),"!"))
}
subfun <- function(stocks,melt){
stocks_char <- paste("(",paste(QT(stocks),collapse=","),")",sep="")
vars <- paste(vars$func,"as",QT(vars$varName), collapse=", ")
querychar <- paste("select ID as stockID,TradingDay as date,",vars,"from QT_IndexQuote where ID in", stocks_char, "and TradingDay >=", begT, "and TradingDay <=" ,endT)
if(datasrc=="quant"){
con <- db.quant()
qt <- queryAndClose.odbc(db.quant(),querychar)
} else if(datasrc=="local"){
qt <- queryAndClose.dbi(db.local("main"),querychar)
}else if(datasrc=="jy"){
stocks_char <- brkQT(substring(stocks,3))
begT <- intdate2r(begT)
endT <- intdate2r(endT)
querychar <- paste("SELECT 'EI'+s.SecuCode 'stockID',CONVERT(varchar,TradingDay,112) 'date',",
vars," FROM QT_IndexQuote q,SecuMain s
where q.InnerCode=s.InnerCode and s.SecuCode in",stocks_char,
" and q.TradingDay>=",QT(begT)," and q.TradingDay<=",QT(endT))
qt <- queryAndClose.odbc(db.jy(),querychar)
qt <- dplyr::arrange(qt,stockID,date)
}
qt$date <- intdate2r(qt$date)
if(melt){
qt <- reshape2::melt(qt,id.vars=c("stockID","date"))
}
return(qt)
}
re <- subfun(stocks,melt)
return(re)
}
#' getPeriodrtn
#'
#' get the period return of the stocks
#' @param SP a \bold{SP} object ('stock*period'): a data frame with cols: "stockID","begT","endT"(with class of Date).
#' @param stockID a vector of stockID
#' @param begT a vector of Date
#' @param endT a vector of Date
#' @param tradeType a character string("close","nextavg","nextopen"),indicating the trading type.
#' @param drop a logical. If the \code{SP} shoud be exculded in the result?
#' @return a data frame, with cols of SP and "periodrtn". Or a vector if \code{drop} is TRUE.
#' @note param SP and combination of stockID, begT and endT should at least have one and only have one. The combination of vector stockID, begT and endT could be different length, which abide by the recycling rule.
#' @author Ruifei.Yin
#' @export
#' @examples
#' # -- with SP
#' getPeriodrtn(data.frame(stockID="EQ601313",begT=as.Date("2012-01-20"),endT=as.Date("2012-09-27")))
#' getPeriodrtn(data.frame(stockID="EQ601313",begT=as.Date("2012-01-20"),endT=as.Date("2012-09-27")),tradeType="nextopen")
#' TS <- getTS(getRebDates(as.Date('2007-03-17'),as.Date('2012-05-20')),'EI000300')
#' TS <- renameCol(TS,"date","begT")
#' SP <- data.frame(TS,endT=trday.offset(TS$begT,months(1)))
#' system.time(re <- getPeriodrtn(SP,datasrc="ts")) # 8.40
#' system.time(re1 <- getPeriodrtn(SP,datasrc="local")) # 1.94
#' system.time(re <- getPeriodrtn(SP,tradeType = "nextavg",datasrc="ts")) # 10.80
#' system.time(re1 <- getPeriodrtn(SP,tradeType = "nextavg",datasrc="local")) # 16.7
#'
#' #-- with combination of vector stockID, begT and endT
#' getPeriodrtn(stockID="EQ000001",begT=as.Date("2012-01-01"), endT=as.Date("2012-01-01")+c(10,20,30))
#' getPeriodrtn(stockID=c("EQ000001","EQ000002","EQ000004"),begT=as.Date("2012-01-01"), endT=as.Date("2013-01-01"))
getPeriodrtn <- function(SP, stockID, begT, endT,
tradeType=c("close","nextavg","nextopen"),drop=FALSE,
datasrc=defaultDataSRC()){
tradeType <- match.arg(tradeType)
if (missing(SP) && any(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should at least have one!")
}
if (!missing(SP) && !all(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should only have one!")
}
if (missing(SP)){
SP <- data.frame(stockID=stockID,begT=begT,endT=endT)
}
check.SP(SP)
if("periodrtn" %in% names(SP)){
warning("Column 'periodrtn' is already exist. It will be drop!")
SP$periodrtn <- NULL
}
if(datasrc=="ts"){
tmpdat <- transform(SP, stockID = stockID2stockID(stockID,from="local",to="ts"),
begT = as.character(begT),
endT = as.character(endT))
tmpcsv <- tempfile(fileext=".csv")
write.csv(tmpdat,tmpcsv,row.names=FALSE,quote=FALSE,fileEncoding="GB2312")
tsRequire()
periodrtn <- tsRemoteCallFunc("getperiodrtn",list(tmpcsv,tradeType))
periodrtn <- plyr::laply(periodrtn,as.array)
re <- cbind(SP, periodrtn)
}
if(datasrc %in% c("quant","local")){
# -- deal with the trading days
if(tradeType=="close"){
tmpdat <- transform(SP[,c("stockID","begT","endT")], begT = trday.nearest(begT), endT = trday.nearest(endT))
tmpdat <- transform(tmpdat, begT = rdate2int(begT), endT = rdate2int(endT))
tmpdat$PK_ <- 1:NROW(tmpdat)
} else {
begT_ <- trday.nearby(TS = dplyr::select(SP,date=begT,stockID),by = 1,drop = TRUE)
endT_ <- trday.nearby(TS = dplyr::select(SP,date=endT,stockID),by = 1,drop = TRUE)
tmpdat <- data.frame(stockID=SP$stockID,begT=begT_,endT=endT_)
tmpdat <- transform(tmpdat, begT = rdate2int(begT), endT = rdate2int(endT))
tmpdat$PK_ <- 1:NROW(tmpdat)
}
# -- query
if(tradeType=="close"){
qr <- "select a.*,b.RRClosePrice as P0,c.RRClosePrice as P1
from temp_table a left join QT_DailyQuote b
on a.begT=b.TradingDay and a.stockID=b.ID
left join QT_DailyQuote as c
on a.endT=c.TradingDay and a.stockID=c.ID"
} else if(tradeType=="nextopen"){
qr <- "select a.*,(b.OpenPrice*b.RRFactor) as P0,(c.OpenPrice*c.RRFactor) as P1
from temp_table a left join QT_DailyQuote b
on a.begT=b.TradingDay and a.stockID=b.ID
left join QT_DailyQuote as c
on a.endT=c.TradingDay and a.stockID=c.ID"
} else if(tradeType=="nextavg"){
qr <- "select a.*,(b.TurnoverValue/b.TurnoverVolume*b.RRFactor) as P0,
(c.TurnoverValue/c.TurnoverVolume*c.RRFactor) as P1
from temp_table a left join QT_DailyQuote b
on a.begT=b.TradingDay and a.stockID=b.ID
left join QT_DailyQuote as c
on a.endT=c.TradingDay and a.stockID=c.ID"
}
# -- fetch
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=tmpdat,tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("qt")
dbWriteTable(con,name="temp_table",value=tmpdat,row.names = FALSE,overwrite = TRUE)
dbExecute(con, 'CREATE INDEX [IX_temp_table] ON [temp_table]([begT],[stockID]);')
dbExecute(con, 'CREATE INDEX [IX2_temp_table] ON [temp_table]([endT],[stockID]);')
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re <- dplyr::arrange(re,PK_)[,c("P0","P1")]
re <- re$P1/re$P0-1
re <- cbind(SP,periodrtn=re)
}
if(drop){
return(re[,"periodrtn"])
} else {
return(re)
}
}
#' @rdname getPeriodrtn
#' @export
#' @examples
#' # -- getPeriodrtn_EI
#' getPeriodrtn_EI(stockID="EI000300",begT=as.Date("2012-01-01"), endT=as.Date("2012-01-01")+c(10,20,30))
getPeriodrtn_EI <- function(SP, stockID, begT, endT, drop=FALSE,
datasrc=defaultDataSRC()){
if (missing(SP) && any(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should at least have one!")
}
if (!missing(SP) && !all(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should only have one!")
}
if (missing(SP)){
SP <- data.frame(stockID=stockID,begT=begT,endT=endT)
}
check.SP(SP)
if(datasrc=="ts"){
tmpdat <- transform(SP, stockID = stockID2stockID(stockID,from="local",to="ts"),
begT = as.character(begT),
endT = as.character(endT))
tmpcsv <- tempfile(fileext=".csv")
write.csv(tmpdat,tmpcsv,row.names=FALSE,quote=FALSE,fileEncoding="GB2312")
tsRequire()
periodrtn <- tsRemoteCallFunc("getperiodrtn",list(tmpcsv,"close"))
periodrtn <- plyr::laply(periodrtn,as.array)
re <- cbind(SP, periodrtn)
}
if(datasrc %in% c("quant","local")){
# -- deal with the trading days
if(TRUE){
tmpdat <- transform(SP[,c("stockID","begT","endT")], begT = trday.nearest(begT), endT = trday.nearest(endT))
tmpdat <- transform(tmpdat, begT = rdate2int(begT), endT = rdate2int(endT))
tmpdat$PK_ <- 1:NROW(tmpdat)
}
# -- query
if(TRUE){
qr <- "select a.*,b.ClosePrice as P0,c.ClosePrice as P1
from temp_table a left join QT_IndexQuote b
on a.begT=b.TradingDay and a.stockID=b.ID
left join QT_IndexQuote as c
on a.endT=c.TradingDay and a.stockID=c.ID"
}
# -- fetch
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=tmpdat,tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
dbWriteTable(con,name="temp_table",value=tmpdat,row.names = FALSE,overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re <- dplyr::arrange(re,PK_)[,c("P0","P1")]
re <- re$P1/re$P0-1
re <- cbind(SP,periodrtn=re)
}
if(drop){
return(re[,"periodrtn"])
} else {
return(re)
}
}
#' @rdname getPeriodrtn
#' @export
#' @examples
#' # -- getPeriodrtn_FU
#' getPeriodrtn_FU(stockID="FUIF00",begT=as.Date("2012-01-01"), endT=as.Date("2012-01-01")+c(10,20,30))
getPeriodrtn_FU <- function(SP, stockID, begT, endT, drop=FALSE,
datasrc="ts"){
if (missing(SP) && any(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should at least have one!")
}
if (!missing(SP) && !all(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should only have one!")
}
if (missing(SP)){
SP <- data.frame(stockID=stockID,begT=begT,endT=endT)
}
check.SP(SP)
if(datasrc=="ts"){# todo
# tmpdat <- transform(SP, stockID = stockID2stockID(stockID,from="local",to="ts"),
# begT = as.character(begT),
# endT = as.character(endT))
# tmpcsv <- tempfile(fileext=".csv")
# write.csv(tmpdat,tmpcsv,row.names=FALSE,quote=FALSE,fileEncoding="GB2312")
# periodrtn <- tsRemoteCallFunc("getperiodrtn",list(tmpcsv,"close"))
# periodrtn <- plyr::laply(periodrtn,as.array)
# re <- cbind(SP, periodrtn)
}
if(datasrc %in% c("quant","local")){
}
if(drop){
return(re[,"periodrtn"])
} else {
return(re)
}
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== gf.xx functions =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' gf_cap
#' @param bc_lambda NULL, "auto", or a specific numeric.
#' @export
#' @examples
#' system.time(re <- gf_cap(ts,datasrc = "local"))
#' system.time(re2 <- gf_cap(ts,datasrc = "memory"))
gf_cap <- function(TS,
log=FALSE,
bc_lambda = NULL,
var=c("float_cap","mkt_cap","free_cap"),
na_fill=TRUE,
varname="factorscore",
datasrc="memory"){
var <- match.arg(var)
# shrink columns, merge back later
TS_core <- TS[,c("date","stockID")]
# retrieve data
if(datasrc=="local"){
if(var=="free_cap"){
re <- gf.free_float_sharesMV(TS_core)
re <- renameCol(re,"factorscore","cap")
} else {
re <- getTech(TS_core,variables=var)
re <- renameCol(re,var,"cap")
re$cap <- re$cap/10000 # 100 million ("yi")
}
} else if(datasrc=="memory"){
memory.load()
TS_core_DT <- data.table(TS_core, key = c("stockID","date"))
marketsize_DT <- data.table(.marketsize, key = c("stockID","date"))
re <- marketsize_DT[TS_core_DT, roll = TRUE]
re <- re[, c("date","stockID",var), with = FALSE]
colnames(re) <- c("date","stockID","cap")
re <- as.data.frame(re)
}
if(log){
re$cap <- log(re$cap)
}
if(!is.null(bc_lambda)){
re <- factor_bcPower(re, fname = "cap", lambda = bc_lambda)
}
if(na_fill){
re[is.na(re$cap),"cap"] <- median(re$cap, na.rm = TRUE)
}
re <- renameCol(re,"cap",varname)
# merge back
re <- merge.x(TS, re, by = c("date","stockID"))
return(re)
}
#' fl_cap
#' @export
fl_cap <- function(log=FALSE,bc_lambda=NULL,var="float_cap",na_fill=TRUE,datasrc="memory"){
re <- list(
factorFun = "gf_cap",
factorPar = list(log=log, bc_lambda=bc_lambda, var=var, na_fill=na_fill,datasrc=datasrc),
factorDir = 1 ,
factorRefine = list(
outlier=list(method = "none", par=NULL, sectorAttr= NULL),
std=list(method = "none", log=FALSE, sectorAttr=NULL, regLists=NULL),
na=list(method = "none", sectorAttr=NULL)
),
factorName = if(log) "ln_cap" else "cap",
factorID = "",
factorType = "",
factorDesc = ""
)
return(re)
}
#' gf.free_float_shares
#' @export
gf.free_float_shares <- function(TS){
check.TS(TS)
qr <- "select b.date, b.stockID,a.freeShares as 'factorscore'
from QT_FreeShares a, temp_table b
where a.rowid=(
select rowid from QT_FreeShares
where stockID=b.stockID and date<=b.date
order by date desc limit 1)"
TS$date <- rdate2int(TS$date)
con <- db.local("main")
dbWriteTable(con,name="temp_table",value=TS[,c("date","stockID")],row.names = FALSE,overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
re <- merge.x(TS[,c("date","stockID")],re,by=c("date","stockID"))
re <- transform(re, date=intdate2r(date))
return(re)
}
#' gf.free_float_sharesMV
#' @export
gf.free_float_sharesMV <- function(TS){
check.TS(TS)
ffs <- gf.free_float_shares(TS[,c('date','stockID')])
ffs <- renameCol(ffs,'factorscore','ffshares')
close <- getTech(TS[,c('date','stockID')],variables='close')
re <- merge.x(ffs,close,by=c('date','stockID'))
re <- transform(re,factorscore=ffshares*close)
re <- re[,c("date","stockID","factorscore")]
return(re)
}
raphael210/QDataGet documentation built on May 26, 2019, 11:02 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions tsInclude tsLoad tsRequire rdate2ts tsdate2r ts.wss memory.load TS.sus_res
Documented in memory.load rdate2ts tsdate2r tsInclude tsLoad tsRequire TS.sus_res ts.wss
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx =====================
# ==================== Tinysoft related utility functions ====================
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx =====================
#' tsInclude
#'
#' Series of functions of connect/login Tinysoft server, and remote call funcions of Tinysoft.
#' @param funchar a charactor string of tinysoft script
#' @param pars a list of funchar's parametres
#' @param syspars a list of tinysoft system parametres.(including:StockID CurrentDate Cycle bRate RateDay Precision)
#' @return tsInclude: include and load the external dll;
#' @return tsRequre: test if tinysoft connected, if not, connect it.
#' @author ruifei.yin
#' @export
#' @examples
#' tsInclude()
#' tsConnect()
#' tsLogined()
#' tsRemoteExecute("return close();",list(StockID="SZ000002",CurrentDate=rdate2ts(as.Date("2014-11-11"))))
#' # use ldply/laply/llply to transform the result from list to comfortable form
#' ll <- tsRemoteExecute("return Array(('a':1,'b':4),('a':2,'b':5),('a':3,'b':6));")
#' plyr::ldply(ll,as.data.frame)
#' plyr::laply(ll,as.array)
#' plyr::llply(ll,unlist)
#' tsRemoteCallFunc("close",,list(StockID="SZ000002"))
#' tsRemoteCallFunc("rand",list(2,3))
#' tsDisconnect()
tsInclude <- function(os = R.Version()$arch){
source(paste(.libPaths()[1],"/QDataGet/tslr/tslr.R",sep = ""))
tsLoad(os)
}
#' @rdname tsInclude
#' @export
tsLoad <- function(os = R.Version()$arch){
libpath <- .libPaths()[1]
if(os == "i386"){
dyn.load(paste(libpath,"/QDataGet/tslr/i386/tslr.dll",sep = ""))
}else if(os == "x86_64"){
dyn.load(paste(libpath,"/QDataGet/tslr/x64/tslr.dll",sep = ""))
}
}
#' @export
#' @rdname tsInclude
tsRequire <- function(){
if(!exists("tsLogined")){
tsInclude()
}
if(!is.loaded("tslConnectServer")){
tsLoad()
}
if(tsLogined()==0){
tsConnect()
}
}
#' rdate2ts
#'
#' transform the R date to tinysoft date value
#' @param rdate a vector with \bold{Date} class
#' @param GAP.R2TS the constant of R to tinysoft date-transformating
#' @return a vector containing the tinysoft date value transformed from the R date
#' @seealso \code{\link{tsdate2r}}
#' @author Ruifei.Yin
#' @export
rdate2ts <- function(rdate, GAP.R2TS=25569){
tsdate <- rdate + GAP.R2TS
tsdate <- as.numeric(tsdate)
return(tsdate)
}
#' tsdate2r
#'
#' transform the tinysoft date value to R date
#' @param tsdate a vector containing the tinysoft date value
#' @param GAP.R2TS the constant of R to tinysoft date-transformating
#' @return a vector with \bold{Date} class, transformed from the tinysoft date value
#' @seealso \code{\link{rdate2ts}}
#' @author Ruifei.Yin
#' @export
tsdate2r <- function(tsdate, GAP.R2TS=25569){
rdate <- tsdate - GAP.R2TS
rdate <- as.Date(rdate,origin="1970-01-01")
return(rdate)
}
#' ts.wss
#'
#' realize the "stock-data-expert" functions in Tinysoft.Given the stocklist, get specific variables of the stocks from Tinysoft.
#' @param stocks a vector of stockID.
#' @param funchar expression to get variables from tinysoft,a character string, usually copyed from tinysoft "stock-data-expert". If you want to specify the rptDate by param \code{rptDate}, the expression should be converted simply by replaceing the specified reportdate in the stock-data-expert expression by \code{'Rdate'}. e.g. convert \code{Last12MData(20091231,46002)} to \code{Last12MData(Rdate,46002)}.
#' @param varname vector of charactor string
#' @param rptDate a specified rptDate, with class of Date. Could be missing when unnessasry. See examples for more detail.
#' @param Time a Date object, giving the pn_date() in tinysoft
#' @param Rate a integer,giving the type of rights adjustment, could be one of 0(no adjustment),1(geometric adjustment),2(simple adjustment),3
#' @param RateDay a integer,giving the base date of right adjustment,could be one of 0(the last trading day),-1(the IPO date),or a tinysoft date integer(eg. \code{rdate2ts(as.Date("2010-01-02"))})
#' @param adjust_yoy a logic. If TRUE, param \code{Time} will be set to \code{rptDate.deadline(rptDate)}, the financial index before(not including) \code{rptDate} will be adjusted, the financial index after \code{rptDate} will not be adjusted.
#' @return a dataframe,with cols:stockID,stockName,and the returned variables.
#' @note you can get different financial index by set param Time and param adjust_yoy.
#' If you set param \code{Time} to 1900-01-01, all the financial index returned will not be adjusted; If you set param \code{Time} to \code{Sys.Date()}, all the financial index returned will be adjusted; See example for detail.
#' @export
#' @family stockDataExpert functions
#' @examples
#' stocks <- c("EQ600011","EQ000631","EQ000004")
#' funchar1 <- '"eps",reportofall(9900000,20121231),
#' "zyywlrzzl",reportofall(9900601,20121231),
#' "yszk",report(44009,20121231),
#' "isFinanceCompany",IsFCompany_(),
#' "close",close(),
#' "rtn(%)(19890705,20120705)",StockZf(32694,41095),
#' "Ndayrtn(%)(N=10)",StockZf2(10),
#' "floatMV(20110926)",StockMarketValue(40812)'
#' re1 <- ts.wss(stocks,funchar1)
#'
#' # -- specify the rptDate
#' funchar2 <- '"eps",reportofall(9900000,Rdate),
#' "zyywlrzzl",reportofall(9900601,Rdate),
#' "yszk",report(44009,Rdate),
#' "isFinanceCompany",IsFCompany_(),
#' "close",close(),
#' "rtn(%)(19890705,20120705)",StockZf(32694,41095),
#' "Ndayrtn(%)(N=10)",StockZf2(10),
#' "floatMV(20110926)",StockMarketValue(40812)'
#' re2 <- ts.wss(stocks,funchar2,rptDate=as.Date('2012-12-31'))
#'
#' all.equal(re1,re2) # TRUE
#'
#' # -- getting financial index (adjust or not)
#' ts.wss("EQ000027",'"G_NP_Q",LastQuarterData(Rdate,9900604,0)',as.Date("2007-03-31"),Time=as.Date("1900-06-29")) # 31.8 (07_adj/06_adj-1)
#' ts.wss("EQ000027",'"G_NP_Q",LastQuarterData(Rdate,9900604,0)',as.Date("2007-03-31"),Time=Sys.Date()) # 229.16 (07_unadj/06_unadj-1)
#' ts.wss("EQ000027",'"G_NP_Q",LastQuarterData(Rdate,9900604,0)',as.Date("2007-03-31"),adjust_yoy=TRUE) # 49 (07_unadj/06_adj-1) This is the correct one!
ts.wss <- function(stocks,funchar,varname,rptDate,Time=Sys.Date(),Rate=1,RateDay=0,
adjust_yoy=FALSE){
stocks <- stockID2stockID(stocks,from="local",to="ts")
if(missing(rptDate)) {
rptDate <- 0
} else {
if(adjust_yoy){
Time <- rptDate.deadline(rptDate)
}
rptDate <- rdate2int(rptDate)
}
Time=rdate2ts(Time)
syspars <- list(CurrentDate=Time,bRate=Rate,RateDay=RateDay)
stocks.str <- paste(stocks,collapse=";")
str <- paste('Rdate:=',rptDate,';\n',
'return Query("","',
stocks.str,
'",True,"","stockID",DefaultStockID(),',
funchar,
');',
sep="")
tsRequire()
re <- tsRemoteExecute(str,syspars)
re <- plyr::ldply(re,as.data.frame)
re$stockID <- stockID2stockID(re$stockID,from="ts",to="local")
if(!missing(varname)){
re <- renameCol(re,colnames(re)[-1],varname)
}
return(re)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# ================== tradingday related =============
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' memory.load
#'
#' load frequently used data into memory, including \code{.tradingdays}, \code{.QT_sus_res}, ...
#' @param reload a logic. If reload the memory data?
#' @return return NULL, but load some data into memory.
#' @export
#' @author Ruifei.Yin
memory.load <- function(reload=FALSE){
if(!exists(".tradingdays") || reload){
if(reload){
message("[memory data reloading]")
} else {
message("[memory data loading]")
}
# -- the market trading days
message(" Loading '.tradingdays' ... ")
qr1 <- "select TradingDate from QT_TradingDay where SecuMarket=83 and IfTradingDay=1"
tradingdays <- queryAndClose.dbi(db.local("main"),qr1)[[1]]
.tradingdays <<- intdate2r(tradingdays)
con_qt <- db.local("qt")
con_main <- db.local("main")
# - QT_sus_res
message(" Loading '.QT_sus_res' ... ")
QT_sus_res <- dbReadTable(con_qt,"QT_sus_res")
QT_sus_res <- data.table::data.table(QT_sus_res,key = "stockID")
.QT_sus_res <<- QT_sus_res[is.na(res),res:=99990101
][,`:=`(sus=intdate2r(sus),res=intdate2r(res))
][,-("updateDate"),with=FALSE
]
# -- the market size data frame
message(" Loading '.marketsize' ... ")
.marketsize <<- dbReadTable(con_qt, "QT_Size")
.marketsize$date <<- intdate2r(.marketsize$date)
# - LC_ExgIndustry
message(" Loading '.LC_ExgIndustry' ... ")
LC_ExgIndustry <- dbReadTable(con_main,"LC_ExgIndustry")
LC_ExgIndustry <- data.table::data.table(LC_ExgIndustry,key = "stockID")
.LC_ExgIndustry <<- LC_ExgIndustry[is.na(OutDate),OutDate:=99990101
][,`:=`(InDate=intdate2r(InDate),OutDate=intdate2r(OutDate))]
dbDisconnect(con_qt)
dbDisconnect(con_main)
} else {
.QT_sus_res <- data.table::alloc.col(.QT_sus_res)
.LC_ExgIndustry <- data.table::alloc.col(.LC_ExgIndustry)
}
}
#' TS.sus_res
#'
#' get the suspension and resumption data
#' @return a data.frame with cols: "sus" and "res"
#' @export
#' @author Ruifei.yin
#' @examples
#' TS <- getTS(getRebDates(as.Date("2007-01-01"),as.Date("2016-01-01"),rebFreq = "week"),indexID = "EI000300")
#' microbenchmark::microbenchmark(re <- TS.sus_res(TS,datasrc="memory"),re1 <- TS.sus_res(TS,datasrc = "local"),times = 10) # 100 VS. 3000
TS.sus_res <- function(TS,datasrc="memory"){
TS_ <- TS[,c("date","stockID")]
if(datasrc == "memory"){
memory.load()
TS_ <- data.table::data.table(TS_)
re <- .QT_sus_res[TS_,.(date,stockID,x.sus,x.res),on=.(stockID,sus<=date,res>date)]
re <- renameCol(re,c("x.sus","x.res"),c("sus","res"))
re <- as.data.frame(re)
} else if(datasrc == "local"){
TS_$date <- rdate2int(TS_$date)
con <- db.local("qt")
qr <- paste(
"select date,a.stockID,sus,res
from temp_table as a left join QT_sus_res as b
on a.stockID=b.stockID and sus<=date and (res>date or res is null)" )
dbWriteTable(con,name="temp_table",value=TS_[,c("date","stockID")],row.names = FALSE,overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
re <- dplyr::mutate(re,date=intdate2r(date),sus=intdate2r(sus),res=intdate2r(res))
}
re <- merge.x(TS,re,by=c("date","stockID"),mult = "first")
return(re)
}
#' trday.get
#'
#' get the trading date series from begT to endT
#' @param begT a Date object.The default is as.Date("1990-12-19")
#' @param endT a Date object.The default is Sys.Date()
#' @param stockID a character string or null. If null, the market trading days, other wise the trading days of specific stock.
#' @return a vector of class Date
#' @export
#' @author Ruifei.yin
#' @examples
#' re <- trday.get()
#' re <- trday.get(as.Date("2012-01-01"),as.Date("2012-09-30"))
#' re <- trday.get(as.Date("2012-07-01"),as.Date("2013-03-30"),stockID="EQ000527")
#' system.time(replicate(100,ii <- trday.get(datasrc="local"))) # 14.09
#' system.time(replicate(100,ii <- trday.get(datasrc="memory"))) # 0.39
#' system.time(replicate(100,ii <- trday.get(datasrc="local",stockID="EQ000527"))) # 16.38
#' system.time(replicate(100,ii <- trday.get(datasrc="memory",stockID="EQ000527"))) # 1.25
trday.get <- function(begT=as.Date("1990-12-19"),endT=Sys.Date(),
stockID=NULL,
datasrc="memory"){
# get the market trading days
if(datasrc %in% c("quant","local")){
begT <- max(begT,as.Date("1990-12-19"))
begT <- rdate2int(begT)
endT <- rdate2int(endT)
qr <- paste("select TradingDate from QT_TradingDay where SecuMarket=83 and IfTradingDay=1 and TradingDate between ",begT,"and",endT)
if(datasrc=="quant"){
trday <- queryAndClose.odbc(db.quant(),qr)
} else if(datasrc=="local"){
trday <- queryAndClose.dbi(db.local("main"),qr)
}
re <- trday[[1]]
re <- intdate2r(re)
} else if (datasrc=="memory") {
memory.load()
begT <- max(begT,as.Date("1990-12-19"))
re <- get(".tradingdays")
re <- re[re >= begT & re <= endT]
}
# get the stock's trading days
if(!is.null(stockID)){
TS <- expand.grid(date=re, stockID=stockID)
sus_res <- TS.sus_res(TS,datasrc = datasrc)
isTradingday <- is.na(sus_res$sus)
re <- re[isTradingday]
}
re <- re[order(re)]
return(re)
}
#' trday.is
#'
#' Identify if the date is trading day or not
#' @param datelist a vector of class Date
#' @param stockID a character string or NULL If NULL, the market trading days, other wise the trading days of specific stock.
#' @return a logical vecter with elements TRUE or FALSE depending on whether its argument is an tradingday
#' @export
#' @author Ruifei.Yin
#' @examples
#' datelist <- seq(from=as.Date("2013-01-21"),to=as.Date("2013-01-30"),by="day")
#' trday.is(datelist)
#' trday.is(datelist,stockID="EQ000527")
#' trday.is(TS=TS)
trday.is <- function(datelist,stockID=NULL,TS,
drop=FALSE){
if(is.null(stockID) & missing(TS)){ # the market tradingday
mindt <- min(datelist)
maxdt <- max(datelist)
tradingday <- trday.get(begT=mindt,endT=maxdt,stockID=NULL)
re <- datelist %in% tradingday
return(re)
}
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
sus_res <- TS.sus_res(TS)
isTradingday <- trday.is(sus_res$date,stockID=NULL) & is.na(sus_res$sus)
if(drop){
re <- isTradingday
}else {
re <- cbind(TS,isTradingday)
}
return(re)
}
#' trday.nearest
#'
#' get the nearest tradingday.
#' @param datelist a vector of class Date
#' @param dir a integer. Indicating forward or backward to find, if \code{datelist} is not tradingday. -1 for backward, 1 for forward.
#' @param stockID a character string or null. If null, the market trading days, other wise the trading days of specific stock.
#' @return a vector of class Date, the value of which is the nearest tradingday before/after the \code{datelist} if \code{datelist} is not a tradingday, otherwise,the \code{datelist} itself.
#' @author Ruifei.Yin
#' @export
#' @examples
#' datelist <- as.Date(c("2012-07-21","2012-07-22","2012-07-23","2013-01-30"))
#' trday.nearest(datelist)
#' trday.nearest(datelist, dir = 1)
#' trday.nearest(datelist, dir = 1, stockID="EQ000527")
trday.nearest <- function(datelist, dir=-1L, stockID=NULL, TS,
drop=FALSE){
if(is.null(stockID) & missing(TS)){ # the market tradingday
tradingdays <- trday.get(endT=Sys.Date()+365, stockID=NULL)
if(dir == -1L){
re <- tradingdays[findInterval(datelist, tradingdays)]
} else if(dir == 1L){
re <- tradingdays[findInterval.rightClosed(datelist, tradingdays)+1]
} else {
stop("unsupported \"dir\" argument!")
}
re <- as.Date(re,origin="1970-01-01")
return(re)
}
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
sus_res <- TS.sus_res(TS)
if(dir == -1L){
re <- dplyr::mutate(sus_res,nearest=ifelse(is.na(sus),
trday.nearest(date,dir = -1L),
trday.nearby(sus,by=-1,stockID=NULL)))
} else if(dir == 1L){
re <- dplyr::mutate(sus_res,nearest=ifelse(is.na(sus),
trday.nearest(date,dir = 1L),
res))
} else {
stop("unsupported \"dir\" argument!")
}
re$nearest <- as.Date(re$nearest,origin="1970-01-01")
if(drop){
re <- re$nearest
}else {
re <- dplyr::select(re,-sus,-res)
}
return(re)
}
#' trday.nearby
#'
#' get the nearby tradingday by shifting forward or backward.If the argument datelist is not a tradingday,the tradingday nearest by it will be firstly found by function \code{trday.nearest(by=-1)}.
#' @param datelist a vector of class Date
#' @param by a integer giving the lagging days.If negetive,get the earlyer tradingday,if positive,get the later tradingday.
#' @param stockID a character string or null. If null, the market trading days, other wise the trading days of specific stock.
#' @param dir 1L or -1L. If the result is not trading day, get the nearest trading day, here need the dir param to give a shifting direction. see \code{\link{trday.nearest}}
#' @return a vector of trading days of class Date
#' @export
#' @author Ruifei.Yin
#' @examples
#' (datelist <- as.Date(c("2012-07-21","2012-07-22","2012-07-23","2013-01-30")))
#' trday.nearby(datelist,-20) # the tradingday 20 days earlyer than datelist
#' trday.nearby(datelist,20) # the tradingday 20 days later than datelist
#' trday.nearby(datelist,20,stockID="EQ000527")
trday.nearby <- function(datelist,by, stockID=NULL,
dir=if(by>0) 1L else -1L,
TS,
drop=FALSE){
if(is.null(stockID) & missing(TS)){ # the market tradingday
trdingday.all <- trday.get(endT=Sys.Date()+365, stockID=NULL)
trdlist <- trdingday.all[findInterval(datelist, trdingday.all)] # get the nearest tradingday
lag.trdingday.all <- xts::lag.xts(trdingday.all, -by)
idx <- match(trdlist, trdingday.all)
re <- lag.trdingday.all[idx]
return(re)
}
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
# get the market's nearby tradingday
nearby_market <- trday.nearby(TS$date,by=by,stockID=NULL)
# get the stock's nearest tradingday
nearby <- trday.nearest(TS=data.frame(date=nearby_market,stockID=TS$stockID),dir = dir,drop = TRUE)
if(drop){
re <- nearby
} else {
re <- cbind(TS,nearby)
}
return(re)
}
#' trday.offset
#'
#' offset the datelist by months,quarters,ect. then get the nearest tradingday
#' @param datelist a vector of class Date
#' @param by a period object. See detail in package \code{lubridate}.
#' @param dir 1L or -1L. if the result date is not trdingday, get the forward nearest tradingday or the backward tradingday? See detail in \link{trday.nearest}
#' @param stockID a character string or null. If null, the market trading days, other wise the trading days of specific stock.
#' @return a vector of trading days of class Date
#' @export
#' @author Ruifei.Yin
#' @examples
#' (datelist <- as.Date(c("2012-07-21","2012-07-22","2012-07-23","2013-01-30")))
#' trday.offset(datelist,months(1)) # the tradingdays 1 month after the datelist
#' trday.offset(datelist,months(-1)) # the tradingdays 1 month before the datelist
#' trday.offset(datelist,years(1))
#' trday.offset(datelist,months(-1),stockID="EQ000527")
trday.offset <- function(datelist,by=months(1),stockID=NULL,
dir=if(as.numeric(by)>0) 1L else -1L,
TS,
drop=FALSE){
if(is.null(stockID) & missing(TS)){ # the market tradingday
if (any(c(by@.Data, by@minute, by@hour, by@day) != 0)){
re <- datelist + by
} else { # if handles month and years, should use %m+%
re <- datelist %m+% by
}
re <- trday.nearest(re, dir=dir, stockID=NULL)
return(re)
}
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
# get the market's offset tradingday
offset_market <- trday.offset(TS$date,by=by,dir=dir,stockID=NULL)
# get the stock's offset tradingday
offset <- trday.nearest(TS=data.frame(date=offset_market,stockID=TS$stockID),dir = dir,drop = TRUE)
if(drop){
re <- offset
} else {
re <- cbind(TS,offset)
}
return(re)
}
#' trday.last
#'
#' get the last tradingday. If datelist is tradingday, return trday.nearby(by=-1), else, return trday.nearest(dir=-1)
#' @export
#' @examples
#' (datelist <- seq(from=as.Date("2013-01-21"),to=as.Date("2013-01-30"),by="day"))
#' trday.is(datelist)
#' # -- compare the following three output:
#' trday.last(datelist)
#' trday.nearest(datelist,dir=-1)
#' trday.nearby(datelist,by=-1)
#' # -- return TS
#' stockID=c("EQ000527","EQ000001")
#' trday.last(datelist = datelist,stockID=stockID)
trday.last <- function(datelist,stockID=NULL,TS,drop=FALSE){
if(is.null(stockID) & missing(TS)){ # the market tradingday
re <- datelist
istrday <- trday.is(datelist = datelist, stockID = NULL)
re[istrday] <- trday.nearby(datelist = datelist[istrday], by=-1, stockID=NULL)
re[!istrday] <- trday.nearest(datelist = datelist[!istrday], dir=-1, stockID=NULL)
return(re)
}
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
istrday <- trday.is(TS=TS,drop=TRUE)
TS_istrday <- trday.nearby(TS = TS[istrday,], by = -1)
TS_notrday <- trday.nearest(TS = TS[!istrday,], dir = -1)
re <- rbind(renameCol(TS_istrday,"nearby","last"), renameCol(TS_notrday,"nearest","last"))
re <- merge.x(TS,re,by=c("date","stockID"))
if(drop){
re <- re$last
}else {
re <- re
}
return(re)
}
#' trday.count
#'
#' get the count of the trading days between \code{begT} and \code{endT}.
#' @param begT a Date object.The default is as.Date("1990-12-19")
#' @param endT a Date object.The default is Sys.Date()
#' @param stockID a character string or null. If null, the market trading days, other wise the trading days of specific stock.
#' @return a integer
#' @export
#' @author Ruifei.Yin
#' @examples
#' trday.count(as.Date("2012-01-01"),as.Date("2012-09-30"))
#' trday.count(as.Date("2012-01-01"),as.Date("2012-09-30"),stockID="EQ000527")
trday.count <- function(begT=as.Date("1990-12-19"), endT=Sys.Date(), stockID=NULL){
trdate <- trday.get(begT,endT,stockID=stockID)
re <- length(trdate)
return(re)
}
#' trday.IPO
#' @param stockID a vector
#' @return a vector
#' @export
#' @family SecuMain functions
trday.IPO <- function(stockID,datasrc=defaultDataSRC()){
qr <- paste("select ListedDate,ID from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
re <- tmpdat[match(stockID,tmpdat[,2]),1]
re <- intdate2r(re)
return(re)
}
#' trday.unlist
#' @param stockID a vector
#' @return a vector
#' @export
#' @family SecuMain functions
trday.unlist <- function(stockID,datasrc="jy"){
if(datasrc=="jy"){
stocks <- substr(unique(stockID),3,8)
#get delist date
qr <- paste("SELECT 'EQ'+s.SecuCode 'stockID',convert(varchar,ChangeDate,112) 'delistdate'
FROM LC_ListStatus l
INNER join SecuMain s on l.InnerCode=s.InnerCode and s.SecuCategory=1
where l.ChangeType=4 and l.SecuMarket in (83,90)
and s.SecuCode in",brkQT(stocks))
tmpdat <- queryAndClose.odbc(db.jy(),qr,as.is = TRUE)
re <- tmpdat[match(stockID,tmpdat[,1]),2]
re <- intdate2r(re)
}
return(re)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# ==================== SecuMain related ==============
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' tradeCode2stockID
#'
#' Covert the tradeCode to stockID given specific secucategory.
#' @param tradeCode Vector of character,giving the stock trading code. eg. \code{c("600001","600002","000300")}
#' @param secuCate integer,giving the secuCategory.(1 for A equity,4 for index,...)
#' @param IDsrc a charactor string, could be one of "local","jy","ts","wind",etc.
#' @return a vector,return the stockID of specific datascr.
#' @export
#' @family SecuMain functions
#' @author Ruifei.Yin
#' @examples
#' tradeCode2stockID(c("600001","600002"),secuCate=1)
#' tradeCode2stockID(c("000001","000300"),secuCate=4)
tradeCode2stockID <- function(tradeCode, secuCate=1, IDsrc="local",
datasrc=defaultDataSRC()){
id_var <- switch(IDsrc,
local="ID",
quant="ID",
jy="InnerCode",
ts="StockID_TS",
wind="StockID_wind")
qr <- paste("select secucode,",id_var,"from SecuMain where secucategory=",secuCate)
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr,as.is=1)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
stockID <- tmpdat[match(tradeCode,tmpdat[,1]),2]
return(stockID)
}
intCode2tradeCode <- function(){
# 718-->"000718"
}
#' stockID2tradeCode
#'
#' Covert the stockID to tradeCode.
#' @param stockID a vector of stockID of specific datascr.
#' @param IDsrc a charactor string, could be one of "local","jy","ts","wind",etc.
#' @return a vector of character,giving the stock trading code. eg. \code{c("600001","600002","000300")}
#' @export
#' @family SecuMain functions
#' @author Ruifei.Yin
#' @examples
#' stockID2tradeCode(c("EI000001","EQ000030"),IDsrc="local")
#' stockID2tradeCode(c("SZ000001","SH000030"),IDsrc="ts")
stockID2tradeCode <- function(stockID,IDsrc="local",
datasrc=defaultDataSRC()){
id_var <- switch(IDsrc,
local="ID",
quant="ID",
jy="InnerCode",
ts="StockID_TS",
wind="StockID_wind")
qr <- paste("select secucode,",id_var,"from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr,as.is=1)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
tradeCode <- tmpdat[match(stockID,tmpdat[,2]),1]
return(tradeCode)
}
#' stockID2stockID
#'
#' Covert the stockID to another type of stockID.
#' @param stockID a vector of specific type
#' @param to a character string, giving the type of stockID convered to. Could be one of "local","ts","jy","wind".
#' @param from a character string, giving the type of stockID convered from. Could be one of "local","ts","jy","wind".
#' @return a vector,return the stockID of specific datascr.
#' @export
#' @family SecuMain functions
#' @author Ruifei.Yin
#' @examples
#' stockID2stockID(c("EI000001","EI000300"),to="jy",from="local")
#' stockID2stockID(c("SH000001","SH000300"),to="jy",from="ts")
stockID2stockID <- function(stockID, from, to,
datasrc=defaultDataSRC()){
id_from <- switch(from,
local="ID",
quant="ID",
jy="InnerCode",
ts="StockID_TS",
wind="StockID_wind")
id_to <- switch(to,
local="ID",
quant="ID",
jy="InnerCode",
ts="StockID_TS",
wind="StockID_wind")
qr <- paste("select",id_from,",",id_to,"from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
stockID_to <- tmpdat[match(stockID,tmpdat[,1]),2]
return(stockID_to)
}
#' stockID2name
#' @param stockID a vector
#' @return a vector
#' @export
#' @family SecuMain functions
#' @examples
#' stockID2name("EQ000527")
stockID2name <- function(stockID,datasrc=defaultDataSRC()){
qr <- paste("select SecuAbbr,ID from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
re <- tmpdat[match(stockID,tmpdat[,2]),1]
return(re)
}
#' stockName2ID
#' @param name a characoter vector
#' @return a dataframe with cols: 'SecuAbbr', 'ID'
#' @export
#' @family SecuMain functions
#' @examples
#' stockName2ID("ST")
stockName2ID <- function(name, datasrc=defaultDataSRC()){
qr <- paste("select SecuAbbr, ID from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
re <- tmpdat[grep(name, gsub("\\s*","",tmpdat$SecuAbbr)), ]
return(re)
}
#' SecuMarket
#' @param stockID a vector
#' @return a vector
#' @export
#' @family SecuMain functions
SecuMarket <- function(stockID,datasrc=defaultDataSRC()){
qr <- paste("select SecuMarket,ID from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
re <- tmpdat[match(stockID,tmpdat[,2]),1]
return(re)
}
#' SecuCategory
#' @param stockID a vector
#' @return a vector
#' @export
#' @family SecuMain functions
SecuCategory <- function(stockID,datasrc=defaultDataSRC()){
qr <- paste("select SecuCategory,ID from SecuMain")
if(datasrc=="quant"){
tmpdat <- queryAndClose.odbc(db.quant(),query=qr)
} else if(datasrc=="local") {
tmpdat <- queryAndClose.dbi(db.local("main"),query=qr)
}
re <- tmpdat[match(stockID,tmpdat[,2]),1]
return(re)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== sector components & sectorID =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' getComps
#'
#' get the components of the specific index, sector or plate on certain days.
#' @param ID a character string. The ID of the index, sector or plate. Could be a single-ID-code(eg. "EI000300","ES09440000",...) or a more complicated express containing some set operations and ID-codes(eg. "setdiff(union(EI000300,EI000905),ES09440000)")
#' @param endT a vector of class \code{Date}. IF missing, then get the latest components.
#' @param drop if drop the field of date and return a vector when endT is length 1 ?
#' @return If \code{endT} is missing or is length 1 and \code{drop} is TRUE, a vector of stockID of the components; else a dataframe, with cols: "date" and "stockID"
#' @export
#' @family getComps functions
#' @examples
#' re1 <- getComps("EI000300") # same as getIndexComp("EI000300")
#' ID <- "setdiff(union(EI000300,EI399006),ES09440000)"
#' re2 <- getComps(ID)
#' re3 <- getComps(ID,endT=as.Date(c("2011-12-31","2012-12-31")))
#' more examples:
#' # CSI300 ex. financial servive sector
#' getComps("setdiff(EI000300,ES09440000)")
#' # CSI300 and financial servive sector
#' getComps("intersect(EI000300,ES09440000)")
#' # not drop
#' getComps("EI000300",drop=FALSE)
getComps <- function(ID, endT=Sys.Date(), drop=TRUE, datasrc=defaultDataSRC()){
IDs <- gsub("union|intersect|setdiff|[()]","",ID)
IDs <- strsplit(IDs,split=",")[[1]]
IDs <- unique(IDs[IDs!=""])
IDs_index <- IDs[substring(IDs,1,2)=="EI"]
IDs_sector <- IDs[substring(IDs,1,2)=="ES"]
IDs_plate <- IDs[substring(IDs,1,2)=="EP"]
if(length(IDs_index) > 0){
comp_index <- lapply(IDs_index, FUN=getIndexComp, endT=endT, drop=FALSE, datasrc=datasrc)
names(comp_index) <- IDs_index
} else {
comp_index <- list()
}
if(length(IDs_sector) > 0){
comp_sector <- lapply(IDs_sector, FUN=getSectorComp, endT=endT, drop=FALSE, datasrc=datasrc)
names(comp_sector) <- IDs_sector
} else {
comp_sector <- list()
}
if(length(IDs_plate) > 0){
comp_plate <- lapply(IDs_plate, FUN=getPlateComp, endT=endT, drop=FALSE, datasrc=datasrc)
names(comp_plate) <- IDs_plate
} else {
comp_plate <- list()
}
comps <- c(comp_index,comp_sector,comp_plate)
subfun <- function(endT0){
comps0 <- lapply(comps,function(x) x[x$date==endT0,"stockID"] )
dat0 <- with(comps0,eval(parse(text=ID)))
dat0 <- data.frame(date=endT0,stockID=dat0,stringsAsFactors=FALSE)
return(dat0)
}
re <- plyr::ldply(endT, subfun)
if(length(endT)==1 && drop==TRUE){
return(re$stockID)
} else {
return(re)
}
}
#' getIndexComp
#'
#' get the components of the specific index on certain day.
#' @param indexID the stockID of the index
#' @param endT a vector of class \code{Date}. IF missing, then get the latest components.
#' @param drop if drop the field of date and return a vector when endT is length 1 ?
#' @return If \code{endT} is missing or is length 1 and \code{drop} is TRUE, a vector of stockID of the components; else a dataframe, with cols: "date" and "stockID"
#' @export
#' @examples
#' tmp <- getIndexComp("EI000300",drop=TRUE) # get the latest components, a vector
#' tmp <- getIndexComp("EI000300") # get the latest components, a dataframe
#' tmp <- getIndexComp("EI000300",as.Date("2012-12-31")) # get the components on single day,a vector
#' tmp <- getIndexComp("EI000300",as.Date(c("2011-12-31","2012-12-31"))) # get the components on multi-days, a data frame
#' tmp <- getIndexComp("EI000300",as.Date(c("2005-12-31","2012-12-31"))) # get the components before index's pubdate, a data frame
getIndexComp <- function(indexID, endT=Sys.Date(), drop=FALSE, datasrc=defaultDataSRC()){
pubdate <- trday.IPO(indexID)
endTdf <- data.frame(dateori=endT,date=endT)
if(indexID!='EI000985' && (!is.na(pubdate)) && min(endT)<pubdate){
warning(paste("min(endT):",min(endT)," is earlier than index's published date:",pubdate,". The early components would be approximated!",sep=""))
endT[endT<pubdate] <- pubdate
endTdf <- transform(endTdf,date=endT)
endT <- unique(endT)
}
if(datasrc %in% c("quant","local")){
endT <- rdate2int(endT)
tmpdat <- data.frame(endT=endT)
qr <- paste("SELECT a.endT as date, b.SecuID as stockID from temp_table a, LC_IndexComponent b
where b.IndexID=", QT(indexID),
"and InDate<=endT and (OutDate>endT or OutDate IS NULL)")
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con, sqtable="temp_table", errors=FALSE)
sqlSave(con, dat=tmpdat, tablename="temp_table", safer=FALSE, rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
dbWriteTable(con, name="temp_table", value=tmpdat, row.names = FALSE, overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re$date <- intdate2r(re$date)
}
if(datasrc=="ts"){
endT <- rdate2ts(endT)
indexID <- stockID2stockID(indexID,to="ts",from="local")
subfun <- function(endT0){
tsRequire()
stocks <- tsRemoteCallFunc("GetBKbyDate",list(indexID,endT0))
stocks <- as.vector(as.matrix(stocks))
stocks <- stockID2stockID(stocks,to="local",from="ts")
dat0 <- data.frame(date=tsdate2r(endT0),stockID=stocks,stringsAsFactors=FALSE)
return(dat0)
}
re <- plyr::ldply(endT,subfun)
}
endT <- endTdf$dateori
if(indexID!='EI000985' && (!is.na(pubdate)) && min(endT)<pubdate){
re <- endTdf %>% dplyr::full_join(re,by='date') %>% dplyr::select(-date) %>% dplyr::rename(date=dateori)
ipo <- data.frame(stockID=unique(re$stockID),stringsAsFactors = FALSE)
ipo$ipoday <- trday.IPO(ipo$stockID)
re <- re %>% dplyr::left_join(ipo,by='stockID') %>% dplyr::mutate(gap=date-ipoday) %>%
dplyr::filter(gap>=90) %>% dplyr::select(-ipoday,-gap)
}
re <- dplyr::arrange(re,date,stockID)
if(length(endT)==1 && drop==TRUE){
return(re$stockID)
} else {
return(re)
}
}
#' getIndexCompWgt
#'
#' get the components and wgts of the specific index on certain day.
#' @param indexID the stockID of the index
#' @param endT a vector of class \code{Date}. IF missing, then get the latest components.
#' @return a dataframe, with cols: "date", "stockID","wgt".
#' @export
#' @family getComps functions
#' @examples
#' tmp <- getIndexCompWgt("EI000300") # get the latest components
#' tmp <- getIndexCompWgt("EI000985",as.Date("2012-12-31")) # get the components on single day
#' tmp <- getIndexCompWgt("EI000300",as.Date(c("2011-12-31","2012-12-31"))) # get the components on multi-days
getIndexCompWgt <- function(indexID="EI000300",endT,datasrc=defaultDataSRC()){
if(missing(endT)) endT <- trday.nearby(Sys.Date(),by=-1) # if endT missing, get the nearest wgt data.
endT <- trday.nearest(endT) # if endT is not tradingday, get the nearest trading days.
trday.nearbyinDB <- function(indexID,endT,datasrc){
# sometimes, the index-component-weight in database is not daily data, this function is used to get nearest date on which the weight data is available.
daymat <- data.frame(oldday=endT)
endT <- rdate2int(endT)
qr <- paste(
"SELECT DISTINCT EndDate
FROM LC_IndexComponentsWeight
where IndexID=",QT(indexID),"order by EndDate"
)
if(datasrc=="quant"){
con <- db.quant()
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
re <- dbGetQuery(con,qr)
dbDisconnect(con)
} else if (datasrc=="jy"){
con <- db.jy()
indexID <- stockID2stockID(indexID,to="jy",from="local")
qr <- paste(
"SELECT DISTINCT convert(varchar,EndDate,112) 'EndDate'
FROM LC_IndexComponentsWeight
where IndexCode=",QT(indexID),"order by EndDate"
)
re <- sqlQuery(con,query=qr)
odbcClose(con)
}
if(nrow(re)==0){
return(0)
}
if(min(endT)<min(re$EndDate)){
return(0)
} else{
endT<- re[findInterval(endT,re$EndDate),]
daymat$newday <- endT
return(daymat)
}
}
daymat <- trday.nearbyinDB(indexID,endT,datasrc)
if(is.numeric(daymat)){ # -- calulate the estimated wgt by 'free_foat_MV'
warning("There is no wgt data in table 'LC_IndexComponentsWeight', calulate the estimated wgt by 'free_foat_MV'.")
# TS <- getTS(endT,indexID)
TS <- getIndexComp(indexID = indexID ,endT = endT, drop = FALSE,datasrc=datasrc)
TSF <- gf_cap(TS,var = 'free_cap',na_fill = FALSE,datasrc="memory")
re <- TSF %>% dplyr::mutate(factorscore=ifelse(is.na(factorscore),0,factorscore)) %>%
group_by(date) %>%
dplyr::mutate(wgt=factorscore/sum(factorscore,na.rm=TRUE)) %>%
dplyr::ungroup() %>% dplyr::select(date,stockID,wgt)
re <- as.data.frame(re)
return(re)
}
endT <- unique(daymat$newday)
if(datasrc %in% c("quant","local")){
tmpdat <- data.frame(endT=endT)
qr <- paste("SELECT a.endT as date, b.SecuID as stockID, Weight/100 as wgt
from temp_table a, LC_IndexComponentsWeight b
where b.IndexID=", QT(indexID),
"and a.endT=b.EndDate")
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con, sqtable="temp_table", errors=FALSE)
sqlSave(con, dat=tmpdat, tablename="temp_table", safer=FALSE, rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
dbWriteTable(con, name="temp_table", value=tmpdat, row.names = FALSE, overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re=merge(re,daymat,by.x="date",by.y ="newday" )
re=re[,c("oldday","stockID","wgt")]
colnames(re)<-c("date","stockID","wgt")
}
if(datasrc=="jy"){
indexID <- stockID2stockID(indexID,to="jy",from="local")
subfun <- function(endT0){
qr <- paste(
"SELECT InnerCode as stockID, Weight/100 as wgt
FROM LC_IndexComponentsWeight as a
where IndexCode=",QT(indexID) ,"and a.EndDate=",QT(endT0)
)
dat <- queryAndClose.odbc(db.jy(),query=qr)
if(nrow(dat)==0){
warning(paste("weight data is missing on",endT0,"!"))
} else {
dat <- data.frame(date=intdate2r(endT0),dat,stringsAsFactors=FALSE)
}
return(dat)
}
re <- plyr::ldply(endT,subfun,.progress="text")
re$stockID <- stockID2stockID(re$stockID,to="local",from="jy")
}
re <- dplyr::arrange(re,date,stockID)
return(re)
}
#' getSectorComp
#'
#' get the components of the specific sector on certain day.
#' @param sectorID ID of the sector. eg. "ES09440000" for "financial service" the 1st level sector of SHENWAN; "ES09440100" for "bank" the 2nd level sector of SHENWAN. Get details with \code{CT_industryList()}
#' @param endT a vector of class \code{Date}. IF missing, then get the latest components.
#' @param drop if drop the field of date and return a vector when endT is length 1 ?
#' @return If \code{endT} is missing or is length 1 and \code{drop} is TRUE, a vector of stockID of the components; else a dataframe, with cols: "date" and "stockID"
#' @export
#' @family getComps functions
#' @examples
#' tmp <- getSectorComp("ES09440000") # get the latest components, a vector
#' tmp <- getSectorComp("ES09440000",as.Date("2012-12-31")) # get the components on single day,a vector
#' tmp <- getSectorComp("ES09440000",as.Date(c("2011-12-31","2012-12-31"))) # get the components on multi-days, a data frame
getSectorComp <- function(sectorID, endT=Sys.Date(), drop=TRUE, datasrc=defaultDataSRC()){
level <- CT_industryList(ID=sectorID)$Level
sectorVar <- paste("Code",level,sep="")
if(datasrc %in% c("quant","local")){
endT <- rdate2int(endT)
tmpdat <- data.frame(endT=endT)
qr <- paste("SELECT a.endT as date, b.stockID as stockID from temp_table a, LC_ExgIndustry b
where ",sectorVar,"=", QT(sectorID),
"and InDate<=endT and (OutDate>endT or OutDate IS NULL)")
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con, sqtable="temp_table", errors=FALSE)
sqlSave(con, dat=tmpdat, tablename="temp_table", safer=FALSE, rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
dbWriteTable(con, name="temp_table", value=tmpdat, row.names = FALSE, overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re$date <- intdate2r(re$date)
}
re <- dplyr::arrange(re,date,stockID)
if(length(endT)==1 && drop==TRUE){
return(re$stockID)
} else {
return(re)
}
}
#' @family getComps functions
getPlateComp <- function(plateID,endT,drop,datasrc){
}
#' sectorID2name
#' @export
sectorID2name <- function(sectorID){
tmpdat <- CT_industryList(ID=sectorID)
tmpdat <- tmpdat[,c("IndustryID","IndustryName")]
re <- tmpdat[match(sectorID,tmpdat[,1]),2]
return(re)
}
plateID2name <- function(plateID){
}
#' sectorID2indexID
#' @export
#' @examples
#' sctID <- getSectorID(stockID = "EQ000001",drop=TRUE)
#' sectorID2indexID(sctID)
sectorID2indexID <- function(sectorID,std=24){
qr <-paste("select A.IndustryCode 'sector',B.SecuCode
from LC_CorrIndexIndustry A,SecuMain B
where A.IndexCode = B.InnerCode and A.IndexState in (1,2) and A.IndustryStandard=",std)
tmpdat <- queryAndClose.odbc(db.jy(),qr,stringsAsFactors =FALSE)
if(std==24){
tmpdat$sector <- paste0("ES33",tmpdat$sector)
}else if(std==9){
tmpdat$sector <- paste0("ES09",tmpdat$sector)
}else if(std==3){
tmpdat$sector <- paste0("ES03",tmpdat$sector)
}
re <- tmpdat[match(sectorID,tmpdat[,1]),2]
if(std %in% c(9,24)){
re <- paste0("EI",re)
}
return(re)
}
#' stockID2indexID
#' @export
#' @examples
#' stockID2indexID(stockID = "EQ000001")
stockID2indexID <- function(TS, stockID, withsector = FALSE){
re <- getSectorID(TS = TS, stockID = stockID)
re$indexID <- sectorID2indexID(re$sector)
if(!withsector){
re <- dplyr::select(re, -sector)
}
return(re)
}
#' getSectorID
#'
#' get the sectorID of the stocks on specific dates.
#' @param TS a \bold{TS} object
#' @param stockID a vector of stockID
#' @param endT a vector of Date
#' @param sectorAttr a list(See more in \code{\link{defaultSectorAttr}}) or NULL,or "existing".
#' @param ret a charactor string,could be one of "ID" or "name",indicating sectorID or sectorName returned.
#' @param drop a logical. Shoud the \code{TS} be exculded in the result?
#' @param fillNA logical.
#' @param ungroup integer, or NULL.
#' @return a data.frame,with the same cols of TS,added by "\code{sector}". Or a vector if \code{drop} is TRUE. You can get more sector infomation by \code{\link{CT_industryList}}
#' @note param TS and combination of stockID and endT should at least have one and only have one. The combination of vector stockID and endT could be different length, which abide by the recycling rule.
#' @author Ruifei.Yin
#' @export
#' @examples
#' # - with TS
#' TS <- getTS(getRebDates(as.Date('2007-03-17'),as.Date('2012-05-20')),'EI000300')
#' getSectorID(TS)
#' # - one stock, multiple dates
#' getSectorID(stockID="EQ000001", endT=as.Date(c("2010-01-01","2012-01-01","2013-01-01")))
#' # - one date, multiple stocks
#' getSectorID(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2010-01-01"))
#' # - get 'ZHONGXIN' sector
#' getSectorID(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2010-01-01"), sectorAttr=list(3,1), ret="name")
#' getSectorID(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2010-01-01"), sectorAttr=list(3,2), ret="name")
#' # -- combined sectorAttr
#' test <- getSectorID(TS, sectorAttr= defaultSectorAttr("fct",fct_level = 5))
#' test <- getSectorID(TS, sectorAttr= defaultSectorAttr("ind_fct",ind_std = 33,ind_level = 1,fct_level = 5))
#' test <- getSectorID(TS, sectorAttr= defaultSectorAttr("ind_fct",ind_std = c(336,33),ind_level = 1,fct_level = 5))
#' test <- getSectorID(TS, sectorAttr= defaultSectorAttr("fct",fct_std = buildFactorLists_lcfs(c("F000001","F000006"),factorRefine = refinePar_default("none",NULL)),fct_level = 5))
#' factorList1 <- buildFactorList(factorFun = "gf_cap",factorRefine=refinePar_default("scale",NULL))
#' test2 <- getSectorID(TS, sectorAttr= list(std=list(factorList1,33),level=list(5,1)))
#' # - speed compares (20 VS. 200)
#' microbenchmark::microbenchmark(re <- getSectorID(TS,datasrc="memory"),re1 <- getSectorID(TS,datasrc = "local"),times = 10)
getSectorID <- function(TS, stockID, endT=Sys.Date(),
sectorAttr=defaultSectorAttr(),
ret=c("ID","name"),
drop=FALSE,
fillNA=FALSE,
ungroup=NULL,
datasrc="memory"){
if(identical(sectorAttr,"existing") | is.null(sectorAttr)){
return(TS)
}
# arguments checking
ret <- match.arg(ret)
if (missing(TS) && missing(stockID)) {
stop("Param TS and combination of stockID and endT should at least have one!")
}
if (!missing(TS) && !missing(stockID)) {
stop("Param TS and combination of stockID and endT should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=endT, stockID=stockID)
}
names(sectorAttr) <- c("std","level")
if(length(sectorAttr$std) != length(sectorAttr$level)) stop("The argument of sectorAttr is not complete.")
if("sector" %in% colnames(TS)){
warning('There is already a "sector" field in TS, it will be overwritten!')
TS$sector <- NULL
}
# looping
loop <- length(sectorAttr$std)
for( i in 1:loop) {
if(is.numeric(sectorAttr$std[[i]])){ # by industrys
sectorSTD <- sectorAttr$std[[i]]
level <- sectorAttr$level[[i]]
sectorvar <- if (ret=="ID") paste("Code",level,sep="") else paste("Name",level,sep="")
TS_ <- TS[,c("date","stockID")]
if(datasrc %in% c("quant","local")){
TS_$date <- rdate2int(TS_$date)
qr <- paste(
"select date,a.stockID,",sectorvar,"as sector_
from temp_table as a left join LC_ExgIndustry as b
on a.stockID=b.stockID and InDate<=date and (OutDate>date or OutDate is null)
where b.Standard=",sectorSTD
)
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=TS_,tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
dbWriteTable(con,name="temp_table",value=TS_,row.names = FALSE,overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re$date <- intdate2r(re$date)
TS <- merge.x(TS,re,by=c("date","stockID"))
} else if (datasrc=="memory"){
memory.load()
TS_ <- data.table::data.table(TS_)
LC_ExgIndustry <- .LC_ExgIndustry[Standard==sectorSTD]
re <- LC_ExgIndustry[TS_,c("date","stockID",paste("x.",sectorvar,sep="")),on=.(stockID,InDate<=date,OutDate>date),with=FALSE]
re <- renameCol(re,paste("x.",sectorvar,sep=""),"sector_")
re <- as.data.frame(re)
TS <- merge.x(TS,re,by=c("date","stockID"))
}
if(fillNA){
TS$sector_ <- sector_NA_fill(sector = TS$sector_, sectorAttr = list(std = sectorSTD, level = level))
}
} else { # by factors
factorList <- sectorAttr$std[[i]]
level <- sectorAttr$level[[i]]
tmpTS <- TS[,c("date","stockID")]
tmpTSF <- getTSF(TS = tmpTS, FactorList = factorList)
tmpTSF <- dplyr::group_by(tmpTSF, date)
tmpTSF <- dplyr::mutate(tmpTSF,sector_=cut(rank(-factorscore,na.last="keep"),breaks =level,labels=FALSE))
tmpTSF <- dplyr::select(tmpTSF,-factorscore)
TS <- merge.x(TS,tmpTSF, by=c("date","stockID"))
}
# join together
if(i==1L){
TS <- renameCol(TS,"sector_","sector")
} else {
TS$sector <- paste(TS$sector, TS$sector_, sep="_")
TS <- dplyr::select(TS,-sector_)
}
}
# ungroup
if(!is.null(ungroup)){
TS <- sector_ungroup(TS,N=ungroup)
}
# return
if(drop){
return(TS[,"sector"])
} else {
return(TS)
}
}
#' is component of specific sector or index?
#'
#' @param sectorID a character string. The ID of the index, sector or plate. See detail in \code{\link{getComps}}
#' @return a dataframe or a vector(if drop==TRUE)
#' @export
#' @examples
#' is_component(stockID = c("EQ000001","EQ300089"),sectorID = "EI000300",drop=TRUE)
#' is_component(stockID = c("EQ000001","EQ300089"),sectorID = "ES09440000")
#' TS <- getTS(as.Date(c("2014-01-01","2016-01-01")),indexID = "EI000906")
#' re <- is_component(TS,sectorID = "EI000300")
is_component <- function(TS, stockID, endT=Sys.Date(),
sectorID,
drop=FALSE,
datasrc=defaultDataSRC()){
if (missing(TS) && missing(stockID)) {
stop("Param TS and combination of stockID and endT should at least have one!")
}
if (!missing(TS) && !missing(stockID)) {
stop("Param TS and combination of stockID and endT should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=endT, stockID=stockID)
}
indexComp <- getComps(sectorID,unique(TS$date),drop = FALSE,datasrc = datasrc)
indexComp$is_comp <- 1L
TSF <- merge.x(TS,indexComp,by=c('date','stockID'))
TSF[is.na(TSF$is_comp),"is_comp"] <- 0
if(drop){
return(TSF[,"is_comp"])
} else {
return(TSF)
}
}
#' deal with the NA value of sectorID
#'
#' replace the NA value of sectorID with an "OTHER" sector
#' @param sector a charactor vector of sectorID
#' @export
sector_NA_fill <- function(sector, sectorAttr=defaultSectorAttr()){
Standard=c( 3, 3, 3, 9, 9, 9, 9, 9, 33, 33, 33, 336)
Level=c( 1, 2, 3, 1, 2, 3, 98, 99, 1, 2, 3, 1)
IndustryID=c( 'ES0370', 'ES037010', 'ES03701010', 'ES09510000', 'ES09510100', 'ES09510101', 'ES0951000098', 'ES0951000099', 'ES33510000','ES33510100','ES33510101', 'ES6')
replace_sec_value <- IndustryID[Standard==sectorAttr[[1]]&Level==sectorAttr[[2]]]
sector[is.na(sector)] <- replace_sec_value
return(sector)
}
# inner-func
# Turn two-stage group ID to one-stage when group members is less than a certain number.
sector_ungroup <- function(TSS,N=10){
if(stringr::str_detect(TSS[1,"sector"],'_') && substr(TSS$sector,1,2)=="ES"){
nsector <- TSS %>% group_by(date,sector) %>% summarise(num=n()) %>% ungroup()
if(any(nsector$num<N)){
nsector <- tidyr::separate(nsector,'sector',c("ind","fct"),sep="_",remove=FALSE)
nsector <- nsector %>% group_by(date,ind) %>% mutate(minnum=min(num)) %>% ungroup()
nsector <- transform(nsector,
sectornew=ifelse(minnum<N,ind,stringr::str_c(ind,fct,sep="_")))
TSS <- dplyr::left_join(TSS,nsector[,c("date","sector","sectornew")],by=c('date','sector'))
TSS <- transform(TSS,sector=sectornew,sectornew=NULL)
}
}
return(TSS)
}
#' @rdname getSectorID
#' @export
gf_sector <- function(TS, sectorAttr) {
TSS <- getSectorID(TS,sectorAttr = sectorAttr,fillNA = TRUE)
re <- cast_sector(TSS)
return(re)
}
#' @rdname getSectorID
#' @param TSS a dataframe, with cols: date,stockID,and some dummy variables of sectors.
#' @export
cast_sector <- function(TSS){
check.TSS(TSS)
TSS$.tmp <- 1
re <- reshape2::dcast(TSS,date+stockID~sector,fill=0,value.var = '.tmp')
TSS$.tmp <- NULL
re <- merge.x(TSS,re,by = c("date","stockID"))
return(re)
}
#' check.colnames_sectorfs
#'
#' @export
check.colnames_sectorfs <- function(data){
check.colnames(data,"sector")
cols <- colnames(data)
if(!any(substr(cols,1,2)=="ES")){
stop("the data must contain the sector-factors!")
}
}
#' defaultSectorAttr
#'
#' get the sectorAttr list.
#' @param type Currently supporting types : ind, fct, ind_fct, fct_ind
#' @param ind_std vector of integer.
#' @param ind_level vector of integer
#' @param fct_std a \bold{FactorLists} object
#' @param fct_level vector of integer. The number of fct splitted groups.
#' @return A \bold{sectorAttr} object. A list with two items:
#' \itemize{
#' \item std: a list( or a vector, if sector standards only include industry, not include factors) of sector standard;
#' \item level: a vector of sector level
#' }
#' @export
#' @examples
#' defaultSectorAttr()
#' defaultSectorAttr("ind",ind_std=c(3,33))
#' defaultSectorAttr("fct")
#' defaultSectorAttr("ind_fct")
#' defaultSectorAttr("fct_ind")
#' defaultSectorAttr("ind_fct",fct_level=5)
#' defaultSectorAttr("ind_fct",fct_std = RFactorModel::buildFactorLists_lcfs(c("F000001","F000006")),fct_level=c(2,3))
defaultSectorAttr <- function(type = c("ind","fct","ind_fct","fct_ind"),
ind_std = 33,
ind_level=1,
fct_std = list(fl_cap()),
fct_level = 3){
type <- match.arg(type)
if(length(ind_std)>length(ind_level)){
ind_level <- rep(ind_level,length(ind_std))
}
if(length(fct_std)>length(fct_level)){
fct_level <- rep(fct_level,length(fct_std))
}
if(type == "ind"){
re <- list(std = ind_std, level = ind_level)
} else if(type =="fct"){
re <- list(std = fct_std, level = fct_level)
} else if(type == "ind_fct"){
re <- list(std = c(as.list(ind_std), fct_std), level = c(ind_level, fct_level))
} else if (type == "fct_ind"){
re <- list(std = c(fct_std, as.list(ind_std)), level = c(fct_level, ind_level))
}
return(re)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== Constant value infomation =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' CT_SystemConst
#' @export
#' @examples
#' CT_SystemConst(LB=1081)
CT_SystemConst <- function(LB,datasrc=defaultDataSRC()){
qr <- "select * from CT_SystemConst"
if(datasrc=="local"){
re <- queryAndClose.dbi(db.local("main"),qr)
} else if(datasrc=="quant"){
re <- queryAndClose.odbc(db.quant(),qr)
} else if(datasrc=="jy"){
re <- queryAndClose.odbc(db.jy(),qr)[,c("LB","LBMC", "DM","MS")]
}
if(!missing(LB)){
re <- re[re$LB==LB,]
}
return(re)
}
#' CT_SecuCategory
#' @export
#' @examples
#' CT_SecuCategory(DM=c(1,4))
#' CT_SecuCategory(MS="xxx")
#' CT_SecuCategory()
CT_SecuCategory <- function(DM,MS){
re <- CT_SystemConst(LB=1177)
if(!missing(DM)){
re <- re[re$DM %in% DM, ]
}
if(!missing(MS)){
re <- re[grep(MS,re$MS),]
}
return(re)
}
#' CT_SecuMarket
#' @export
#' @examples
#' CT_SecuMarket(DM=c(83,90))
#' CT_SecuMarket(MS="xxx")
#' CT_SecuMarket()
CT_SecuMarket <- function(DM,MS){
re <- CT_SystemConst(LB=201)
if(!missing(DM)){
re <- re[re$DM %in% DM, ]
}
if(!missing(MS)){
re <- re[grep(MS,re$MS),]
}
return(re)
}
#' CT_sectorSTD
#' @export
#' @examples
#' CT_sectorSTD(DM=9)
#' CT_sectorSTD(DM=c(3,9))
#' CT_sectorSTD(MS="xxx")
#' CT_sectorSTD()
CT_sectorSTD <- function(DM,MS){
re <- CT_SystemConst(LB=1081)
if(!missing(DM)){
re <- re[re$DM %in% DM, ]
}
if(!missing(MS)){
re <- re[grep(MS,re$MS),]
}
return(re)
}
#' CT_industryList
#' @export
#' @examples
#' re <- CT_industryList(std=c(9,3))
#' CT_industryList(std=9,level=1)
#' CT_industryList(ID=c("ES0310","ES0312"))
#' CT_industryList(name="SHENWAN")
CT_industryList <- function(std,level,ID,name,
datasrc=defaultDataSRC()){
qr <- "select * from CT_IndustryList"
if(datasrc=="local"){
re <- queryAndClose.dbi(db.local("main"),qr)
} else if(datasrc=="quant"){
re <- queryAndClose.odbc(db.quant(),qr)
}
if(!missing(std)){
re <- re[re$Standard %in% std, ]
}
if(!missing(level)){
re <- re[re$Level %in% level, ]
}
if(!missing(ID)){
re <- re[re$IndustryID %in% ID, ]
}
if(!missing(name)){
re <- re[grep(name,re$IndustryName),]
}
return(re)
}
#' CT_TechVars
#' @export
CT_TechVars <- function(datasrc,secuCate,tableName,vars){
# -- Only local database allowed!
re <- queryAndClose.dbi(db.local("main"),"select * from CT_TechVars")
if(! missing(datasrc)){
re <- re[re$datasrc==datasrc,]
}
if(! missing(secuCate)){
re <- re[re$secuCate==secuCate,]
}
if(! missing(tableName)){
re <- re[re$tableName==tableName,]
}
if(! missing(vars)){
re <- re[re$varName %in% vars,]
}
return(re)
}
#' CT_FactorLists
#' @export
CT_FactorLists <- function(factorID,factorName,factorType,type = c("all", "alpha", "risk")){
# -- Only local database allowed!
type <- match.arg(type)
if(type == "all"){
re1 <- queryAndClose.dbi(db.local("fs"),"select * from CT_FactorLists")
re2 <- queryAndClose.dbi(db.local("fs_r"),"select * from CT_FactorLists_R")
re <- rbind(re1, re2)
}else if(type == "alpha"){
re <- queryAndClose.dbi(db.local("fs"),"select * from CT_FactorLists")
}else if(type == "risk"){
re <- queryAndClose.dbi(db.local("fs_r"),"select * from CT_FactorLists_R")
}
#
if(! missing(factorID)){
re <- re[match(factorID,re[,1]),]
}
if(! missing(factorName)){
re <- re[re$factorName %in% factorName,]
}
if(! missing(factorType)){
re <- re[re$factorType %in% factorType,]
}
#
return(re)
}
#' factorID2name
#' @export
factorID2name <- function(factorID){
re <- CT_FactorLists(factorID)$factorName
return(re)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== Future related =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' getIFlastfirstday
#'
#' get the first,last and open dates of all IFs.
#'
#' Note that the "firstday" is the date when the current-month IF switching,while the "openday" is the date the IF IPOing.
#' @param begM beginning month,a yearmon object.
#' @param endM ending month,a yearmon object.
#' @return a dataframe,with cols: date(of class Date),IF01(of class character) and firstday,lastday,openday(of class Date)
#' @export
#' @author Ruifei.Yin
#' @examples
#' getIFlastfirstday()
getIFlastfirstday <- function(begM=zoo::as.yearmon("2010-05"),endM=zoo::as.yearmon(Sys.Date())){
dt <- seq(from=zoo::as.Date(zoo::as.yearmon("2010-05")),to=Sys.Date()+1/12,by="month")
IF01 <- paste("IF",substr(as.character(dt),3,4),substr(as.character(dt),6,7),sep="")
# ---- lastday
lastday0 <- as.Date(timeDate::timeNthNdayInMonth(dt,5,3))
lastday <- as.Date(ifelse(trday.is(lastday0)|(lastday0>=Sys.Date()),lastday0,trday.nearby(lastday0,1)))
# ---- firstday
lastday_lag <-lag.m(lastday,1,TRUE)
firstday <- as.Date(ifelse(dt!=as.Date("2010-05-01"),trday.nearby(lastday_lag,1),as.Date("2010-04-16")))
firstday <- as.Date(ifelse(lastday_lag>=Sys.Date()&(!is.na(lastday_lag)),lastday_lag+3,firstday)) # this is a very tricky method!
# ---- openday
openday <- vector(length=length(dt))
for(ii in 1:length(dt)){
mm <-month(dt[ii])
if(mm %in% c(3,6,9,12)){
if(ii<=7){
openday[ii] <-as.Date("2010-04-16")
} else {
openday[ii] <-firstday[ii-7]
}
} else {
if(ii<=1){
openday[ii] <-as.Date("2010-04-16")
} else {
openday[ii] <-firstday[ii-1]
}
}
}
openday <- as.Date(openday)
# ---- merge and subset
re <- data.frame(date=dt,IF01,firstday,lastday,openday,stringsAsFactors=FALSE)
begM <- max(zoo::as.yearmon("2010-05"),begM)
endM <- min(zoo::as.yearmon(Sys.Date())+1/12,endM)
re <- re[re$date>=as.Date(begM)&re$date<=as.Date(endM),]
return(re)
}
#' getIFlist
#'
#' get the list(the 4 future at one time) of codes of all CSI300 index futures and the first and last day of every current-month future.
#' @param begM beginning month,a yearmon object.
#' @param endM ending month,a yearmon object.
#' @return a dataframe,with cols: date,IF01,IF02,IF03,IF04,firstday,lastday,openday
#' @export
#' @author Ruifei.Yin
#' @examples
#' getIFlist()
getIFlist <- function(begM=zoo::as.yearmon("2010-05"),endM=zoo::as.yearmon(Sys.Date())){
begM <- max(zoo::as.yearmon("2010-05"),begM)
endM <- min(zoo::as.yearmon(Sys.Date())+1/12,endM)
d1 <- seq(from=as.Date(begM),to=as.Date(endM),by="month")
d2 <- d1+months(1)
d3 <- vector(length=length(d1))
for(i in 1:length(d1)){
mm <-month(d1[i])
if(mm %in% c(1,4,7,10)){d3[i] <-d1[i]+months(2)}
if(mm %in% c(2,5,8,11)){d3[i] <-d1[i]+months(4)}
if(mm %in% c(3,6,9,12)){d3[i] <-d1[i]+months(3)}
}
d3 <- as.Date(d3)
d4 <- d3+months(3)
IF01 <- paste("IF",substr(as.character(d1),3,4),substr(as.character(d1),6,7),sep="")
IF02 <- paste("IF",substr(as.character(d2),3,4),substr(as.character(d2),6,7),sep="")
IF03 <- paste("IF",substr(as.character(d3),3,4),substr(as.character(d3),6,7),sep="")
IF04 <- paste("IF",substr(as.character(d4),3,4),substr(as.character(d4),6,7),sep="")
IFlist <- data.frame(date=d1,IF01,IF02,IF03,IF04,stringsAsFactors=FALSE)
IFlastfirstday <- getIFlastfirstday(begM,endM)
re <- merge(IFlist,IFlastfirstday)
return(re)
}
#' getIFcontinuousCode
#'
#' get the continuous index future code on every trading day
#' @return a datafame with cols:tradingday,IF00,IF01,IF02,IF03,IF04,firstday,lastday...
#' @export
#' @author Ruifei.Yin
#' @examples
#' begT <- as.Date("2010-04-16")
#' endT <- Sys.Date()
#' getIFcontinuousCode()
getIFcontinuousCode <- function(begT=as.Date("2010-04-16"),endT=Sys.Date()){
tradingday <- data.frame(tradingday=trday.get(begT,endT),stringsAsFactors=FALSE)
IFlist <- getIFlist()
sqlchar1 <- "select * from tradingday as a ,IFlist as b
where a.tradingday <= b.lastday and a.tradingday >= b.firstday"
re <- sqldf(sqlchar1)
return(re)
}
#' getIFrtn
#'
#' get index future daily return series
#' @param code the code of the future(eg."IF00","IF01","IF02"...)
#' @param begT an object of class "Date"
#' @param endT an object of class "Date"
#' @param adj a logical,with default FALSE. if true, the daily return of future will be aligned with the trading time(starting from 9:30 and ending to 15:30) of CSI300 index.
#' @return the daily return series of class xts.
#' @export
#' @author Ruifei.Yin
#' @examples
#' begT <- as.Date("2011-01-01")
#' endT <- as.Date("2011-02-01")
#' rtn <- getIFrtn("IF00",begT,endT)
#' rtn.adj <- getIFrtn("IF00",begT,endT,adj=TRUE)
getIFrtn <- function(code,begT,endT,adj=FALSE){
qt <- getQuote_ts(code,begT,endT,variables=c("price","yclose"),Cycle="cy_15m()")
rtn <- qt$price/qt$yclose-1
time <- qt$date
time.adj<- time
for(ii in 1:length(time)){
if(lubridate::hour(time[ii])==15 & lubridate::minute(time[ii])==15){
time.adj[ii] <- time[ii+1]-3600
}
}
if(adj){
rtn.xts <- xts(rtn,time.adj)
} else {
rtn.xts <- xts(rtn,time)
}
rtn.daily <- aggregate(rtn.xts,by=zoo::as.Date,PerformanceAnalytics::Return.cumulative)
colnames(rtn.daily) <- code
return(rtn.daily)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== rptDate related =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# -------------------- ~~ rptDate funcs ----------------
#' rptDate.is
#'
#' Is it a proper report date?
#' @param rptDate a vector of rptDate , with class Date.
#' @return a logical vector with the same length of rptDate.
#' @export
#' @author Ruifei.Yin
#' @seealso \code{\link{check.rptDate}}
#' @examples
#' rptDate.is(ymd(c(20100103,20141231,20130630)))
#' rptDate.is(ymd(c(20100630,20141231,20130930)))
#' rptDate.is(ymd(c(20100630,20141231,20130930)),"h")
rptDate.is <- function(rptDate,freq=c("q","y","h")){
freq <- match.arg(freq)
md <- 100*lubridate::month(rptDate) + lubridate::day(rptDate)
if(freq=="q"){
re <- md %in% c(331,630,930,1231)
} else if(freq=="h"){
re <- md %in% c(630,1231)
} else {
re <- md %in% c(1231)
}
return(re)
}
#' check.rptDate
#'
#' Is it a proper rptDate object? If TRUE, return NULL; else return an error.
#' @param rptDate a vector of rptDate , with class Date.
#' @export
#' @author Ruifei.Yin
#' @seealso \code{\link{rptDate.is}}
#' @examples
#' check.rptDate(ymd(c(20100103,20141231,20130630)))
#' check.rptDate(ymd(c(20100630,20141231,20130930)))
check.rptDate <- function(rptDate){
rptDate <- na.omit(rptDate) # omit the NA
re <- rptDate.is(rptDate)
re_all <- all(re)
if(!re_all) {
warning("rptDate is not proper report date!")
message("Following is not proper rptDate:")
print(rptDate[!re])
}
}
#' rptDate.yoy
#' @param rptDate a vector of rptDate , with class Date.
#' @return a vector of yoy rptDate.
#' @export
#' @author Ruifei.Yin
#' @examples
#' rptDate.yoy(lubridate::ymd(c(20100630,20141231,20130930)))
rptDate.yoy <- function(rptDate){
check.rptDate(rptDate)
re <- rptDate - lubridate::years(1)
re <- as.Date(re,tz="")
return(re)
}
#' rptDate.qoq
#' @param rptDate a vector of rptDate , with class Date.
#' @return a vector of qoq rptDate.
#' @export
#' @author Ruifei.Yin
#' @examples
#' rptDate.qoq(lubridate::ymd(c(20100630,20141231,20130930)))
rptDate.qoq <- function(rptDate){
check.rptDate(rptDate)
re <- rptDate %m-% months(3)
re <- lubridate::ceiling_date(re,unit="month") - lubridate::days(1)
re <- as.Date(re,tz="")
return(re)
}
#' rptDate.offset
#' @param rptDate a vector of rptDate , with class Date.
#' @param by a vector of integer
#' @param freq charactor string: "y" or "q".
#' @return a vector or a dataframe according to the length of rptDate and by.
#' @export
#' @author Ruifei.Yin
#' @examples
#' # multi rptDate and 1 by:
#' rptDate.offset(as.Date(c("2016-03-31","2016-06-30","2016-09-30")),-1,"q")
#' rptDate.qoq(as.Date(c("2016-03-31","2016-06-30","2016-09-30")))
#' rptDate.offset(as.Date(c("2016-03-31","2016-06-30","2016-09-30")),-1,"y")
#' rptDate.yoy(as.Date(c("2016-03-31","2016-06-30","2016-09-30")))
#' # 1 rptDate and multi by:
#' rptDate.offset(as.Date("2016-03-31"),-2:0,"q")
#' # multi rptDate and multi by:
#' rptDate.offset(as.Date(c("2016-03-31","2016-06-30","2016-09-30")),-2:0,"q")
rptDate.offset <- function(rptDate,by,freq){
check.rptDate(rptDate)
if(length(rptDate)>1 && length(by)>1){
for(i in 1:length(by)){
re_ <- rptDate.offset(rptDate = rptDate, by=by[i], freq=freq)
re_ <- data.frame(re_)
if(i==1L){
re <- re_
} else{
re <- cbind(re,re_)
}
}
colnames(re) <- paste(freq,by,sep = "")
} else {
if(freq=="y"){
re <- rptDate + lubridate::years(by)
}else if(freq=="q"){
re <- rptDate %m+% months(by*3)
re <- lubridate::ceiling_date(re,unit="month") - lubridate::days(1)
}else if(freq=="h"){
re <- rptDate %m+% months(by*6)
re <- lubridate::ceiling_date(re,unit="month") - lubridate::days(1)
}else{
stop("uncorrect freq!")
}
re <- as.Date(re,tz="")
}
return(re)
}
#' rptDate.deadline
#' return the deadline of rptDate.
#' @param rptDate a vector of rptDate, with class Date.
#' @return a vector of Date
#' @export
#' @author Ruifei.Yin
#' @examples
#' rptDate.deadline(ymd(c(20100630,20141231,20130930)))
rptDate.deadline <- function(rptDate){
check.rptDate(rptDate)
q <- lubridate::quarter(rptDate)
y <- lubridate::year(rptDate)
re <- ISOdate(y,4,30,tz="")
re[q==2] <- ISOdate(y[q==2], 8, 31, tz="")
re[q==3] <- ISOdate(y[q==3], 10, 31, tz="")
re[q==4] <- ISOdate(y[q==4]+1, 4, 30, tz="")
re <- as.Date(re,tz="")
return(re)
}
#' rptDate.yearrpt
#' @param datelist a vector of date , with class Date.
#' @return a vector of yearly rptDate.
#' @export
#' @author Ruifei.Yin
#' @examples
#' rptDate.nearest(as.Date(c("2015-01-11","2016-06-21","2016-12-31")),"q",1)
#' rptDate.nearest(as.Date(c("2015-01-11","2016-06-21","2016-12-31")),"y",-1)
rptDate.nearest <- function(datelist,freq=c("q","y","h"),dir=-1L){
freq <- match.arg(freq)
if(freq=="y"){
if(dir==-1L){
re <- dplyr::if_else(rptDate.is(datelist,freq = "y"),datelist,
lubridate::floor_date(datelist,unit="year") - lubridate::days(1))
} else {
re <- lubridate::ceiling_date(datelist,unit="year") - lubridate::days(1)
}
} else if(freq=="q"){
if(dir==-1L){
re <- dplyr::if_else(rptDate.is(datelist,freq = "q"),datelist,
lubridate::floor_date(datelist,unit="quarter") - lubridate::days(1))
} else {
re <- lubridate::ceiling_date(datelist,unit="quarter") - lubridate::days(1)
}
} else if(freq=="h"){
if(dir==-1L){
re <- dplyr::if_else(rptDate.is(datelist,freq = "h"),datelist,
lubridate::floor_date(datelist,unit="halfyear") - lubridate::days(1))
} else {
re <- lubridate::ceiling_date(datelist,unit="halfyear") - lubridate::days(1)
}
}
re <- as.Date(re,tz="")
return(re)
}
#' rptDate.yearrpt
#' @param freq "q","y","h"
#' @param dir 1L,-1L,or 0L
#' @return a vector of yearly rptDate.
#' @export
#' @author Ruifei.Yin
#' @examples
#' rptDate.get(as.Date("2011-02-06"),as.Date("2011-10-23"),freq="h",dir=1)
#' rptDate.get(as.Date("2011-12-31"),as.Date("2013-06-30"),freq="q",dir=0)
rptDate.get <- function(begT, endT, freq=c("q","y","h"), dir=0L){
freq <- match.arg(freq)
datelist <- c(seq(begT,endT,by='month'),endT)
if(dir==-1L){
re <- rptDate.nearest(datelist = datelist, freq = freq, dir = -1L)
}else if(dir==1L){
re <- rptDate.nearest(datelist = datelist, freq = freq, dir = 1L)
}else{
re <- rptDate.nearest(datelist = datelist, freq = freq, dir = -1L)
re <- re[re>=begT & re<=endT]
}
re <- unique(re)
return(re)
}
#' rptDate.publ
#'
#' @export
#' @author Aming.Tao
#' @examples
#' rptTS <- getrptTS(begT=as.Date("2016-02-06"),endT=as.Date("2017-8-23"),univ='EI000300')
#' re <- rptDate.publ(rptTS)
#' rptDate <- rptDate.get(as.Date("2011-02-06"),as.Date("2013-10-23"))
#' re <- rptDate.publ(rptDate=rptDate,stockID=c("EQ000001","EQ000002"))
rptDate.publ <- function(rptTS,rptDate,stockID,datasrc=defaultDataSRC()){
if (missing(rptTS) && any(missing(stockID),missing(rptDate))) {
stop("Param rptTS and combination of stockID and rptDate should at least have one!")
}
if (!missing(rptTS) && !all(missing(stockID),missing(rptDate))) {
stop("Param rptTS and combination of stockID and rptDate should only have one!")
}
if (missing(rptTS)){
rptTS <- expand.grid(rptDate=rptDate, stockID=stockID,stringsAsFactors = FALSE)
}
check.rptTS(rptTS)
if(datasrc=="quant"){
rptTS <- transform(rptTS,rptDate=rdate2int(rptDate))
con <- db.quant()
qr <- paste("select a.*,b.PublDate from temp_table a left join LC_RptDate b on a.stockID=b.stockID and a.rptDate=b.EndDate")
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=rptTS,tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
re <- transform(re,rptDate=intdate2r(rptDate))
}else if(datasrc=="local"){
rptTS <- transform(rptTS,rptDate=rdate2int(rptDate))
con <- db.local("main")
dbWriteTable(con,name="temp_table",value=rptTS,row.names = FALSE,overwrite = TRUE)
qr <- paste("select a.*,b.PublDate from temp_table a left join LC_RptDate b on a.stockID=b.stockID and a.rptDate=b.EndDate")
re <- dbGetQuery(con,qr)
dbDisconnect(con)
re <- transform(re,rptDate=intdate2r(rptDate))
}else if(datasrc=="ts"){
re <- rptTS.getFin_ts(rptTS,'"PublDate",report(128006,RDate)')
}
re <- transform(re,PublDate=intdate2r(PublDate))
return(re)
}
# -------------------- ~~ rptTS funcs ----------------
#' getrptTS
#' @param freq "q","y","h"
#' @param dir 1L,-1L,or 0L
#' @param univ a index or sector ID.
#' @return a \bold{rptTS} object.a dataframe,with cols:
#' \itemize{
#' \item date: the rptDates
#' \item stockID: the stockID
#' }.IF rptDates or stocks is not missing then use them directly, else get rptDates and stocks by \code{\link{rptDate.get}} and \code{\link{getComps}}.
#' @export
#' @author Ruifei.Yin
#' @examples
#' re1 <- getrptTS(begT=as.Date("2011-02-06"),endT=as.Date("2011-10-23"),univ="EI000300")
#' re2 <- getrptTS(rptDates=as.Date(c("2016-03-31","2016-09-30")),univ="EI000300")
#' re3 <- getrptTS(rptDates=as.Date(c("2016-03-31","2016-09-30")),stocks=c("EQ000001","EQ000002"))
#' re4 <- getrptTS(begT=as.Date("2011-02-06"),endT=as.Date("2011-10-23"),stocks=c("EQ000001","EQ000002"))
getrptTS <- function(begT,endT,freq=c("q","y","h"),dir=0,univ,
rptDates,stocks){
freq <- match.arg(freq)
if(missing(rptDates)){
rptDates <- rptDate.get(begT = begT, endT = endT, freq = freq, dir = dir)
}
check.rptDate(rptDates)
if(missing(stocks)){
re <- getComps(ID=univ,endT=rptDates,drop=FALSE)
re <- renameCol(re,"date","rptDate")
} else {
re <- expand.grid(rptDate=rptDates,stockID=stocks)
}
return(re)
}
#' rptTS.getFin
#'
#' get financtial indicators via \bold{rptTS} through WindR, or TinySoft.
#' @rdname rptTS.getFin
#' @name rptTS.getFin
#' @aliases rptTS.getFin_windR
#' @param rptTS a \bold{rptTS} object. a dataframe with cols:"rptDate","stockID"
#' @param field character strting or a vector of character string, giving the windfields. eg. "OPEN,CLOSE,HIGH" or c("OPEN","CLOSE","HIGH")
#' @param varname vector of charactor string
#' @param ... other arguments except \code{rptDate} in \code{w.wss}
#' @return a dataframe with the same length with rptTS, but added by some other financial indicator fields.
#' @export
#' @seealso \code{\link[WindR]{w.wss}}
#' @author Ruifei.Yin
#' @examples
#' rptTS <- getrptTS(begT=as.Date("2011-02-06"),endT=as.Date("2011-10-23"),stocks=c("EQ000001","EQ000002"))
#' # rptTS.getFin_windR
#' re <- rptTS.getFin_windR(rptTS,"np_belongto_parcomsh",options ="rptType=1")
rptTS.getFin_windR <- function(rptTS, field, varname, ...){
check.rptTS(rptTS)
require(WindR)
if(!w.isconnected()){
w.start(showmenu=FALSE)
}
rptTS2 <- transform(rptTS, stockID_wind=stockID2stockID(stockID,from="local",to="wind"), stringsAsFactors=FALSE)
Dts <- unique(rptTS$rptDate)
Dts <- na.omit(Dts)
df <- data.frame()
for(Dt in Dts){
Dt <- as.Date(Dt,origin = "1970-01-01")
codes <- rptTS2[rptTS2$rptDate==Dt, "stockID_wind", drop=TRUE]
w_out <- w.wss(codes=codes, fields=field, paste('rptDate=',rdate2int(Dt)), ...)
if(!w_out$ErrorCode==0){
stop(paste('Error in w.wss running! rptDate =',rdate2int(Dt),'; errorcode=',w_out$ErrorCode))
}
out <- data.frame(rptDate=Dt, w_out$Data)
if(dim(df)[1]==0) {
df <- out
} else {
df <- rbind(df,out)
}
}
df$stockID <- stockID2stockID(df$CODE,"wind","local")
re <- merge.x(rptTS,df,by=c("rptDate","stockID"))
re$CODE <- NULL
if(!missing(varname)){
re <- renameCol(re,setdiff(names(re),names(rptTS)), varname)
}
return(re)
}
#' @rdname rptTS.getFin
#' @param funchar expression to get variables from tinysoft,a character string, usually copyed from tinysoft "stock-data-expert" and then replace the specified reportdate in the stock-data-expert expression by \code{'Rdate'}. e.g. convert \code{Last12MData(20091231,46002)} to \code{Last12MData(Rdate,46002)}.
#' @note the funchar param could also be a 'multi_funchar', to get multi-factors. See details in the examples.
#' @param ... other arguments in \code{ts.wss}.
#' @export
#' @seealso \code{\link{ts.wss}}
#' @examples
#' # rptTS.getFin_ts
#' re2 <- rptTS.getFin_ts(rptTS,'"np_belongto_parcomsh",report(46078,RDate)')
#' multi_funchar <- '"eps",reportofall(9900000,RDate),
#' "zyywlrzzl",reportofall(9900601,RDate),
#' "yszk",report(44009,RDate)'
#' re3 <- rptTS.getFin_ts(rptTS,multi_funchar)
rptTS.getFin_ts <- function(rptTS, funchar,varname, ...){
check.rptTS(rptTS)
Dts <- unique(rptTS$rptDate)
Dts <- na.omit(Dts)
df <- data.frame()
for(Dt in Dts){
Dt <- as.Date(Dt,origin = "1970-01-01")
codes <- rptTS[rptTS$rptDate==Dt, "stockID", drop=TRUE]
ts_out <- ts.wss(stocks=codes, funchar=funchar,varname = varname, rptDate=Dt, adjust_yoy=TRUE, ...)
out <- data.frame(rptDate=Dt, ts_out)
if(dim(df)[1]==0) {
df <- out
} else {
df <- rbind(df,out)
}
}
re <- merge.x(rptTS,df,by=c("rptDate","stockID"))
re$stockName <- NULL
return(re)
}
#' @rdname rptTS.getFin
#' @export
#' @examples
#' # rptTS.getFinSeri_ts
#' FinSeri <- rptTS.getFinSeri_ts(rptTS,12,"q",'"np_belongto_parcomsh",report(46078,RDate)')
#' Finseri2 <- rptTS.getFinSeri_ts(rptTS,3,"y",multi_funchar)
rptTS.getFinSeri_ts <- function(rptTS, N, freq, funchar,varname, ...){
check.rptTS(rptTS)
# get rptTS_seri
rptDate_df <- rptDate.offset(rptTS$rptDate, by=-(N-1):0, freq = freq)
rptTS_seri <- cbind(rptTS[,c("stockID","rptDate")],rptDate_df)
rptTS_seri <- reshape2::melt(rptTS_seri,id.vars=c("stockID","rptDate"),variable.name="lagN",value.name="lag_rptDate")
# remove repdate before IPO
rptTS_seri$ipoDate <- trday.IPO(rptTS_seri$stockID)
rptTS_seri <- dplyr::filter(rptTS_seri,lag_rptDate>=ipoDate)
rptTS_seri <- dplyr::arrange(rptTS_seri,stockID,rptDate,desc(lag_rptDate))
# get the financial index data
rptTS_uniq <- unique(rptTS_seri[,c("stockID","lag_rptDate")])
rptTS_uniq <- renameCol(rptTS_uniq,"lag_rptDate","rptDate")
rptTS_uniq <- rptTS.getFin_ts(rptTS=rptTS_uniq,funchar=funchar, varname = varname, ...)
rptTS_uniq <- renameCol(rptTS_uniq,"rptDate","lag_rptDate")
re <- merge.x(rptTS_seri,rptTS_uniq,by =c("stockID","lag_rptDate"))
return(re)
}
#' calcFinStat
#'
#' @param fname this function can deal with multifactors. one can select which factors to calculate stat through fname param.
#' @export
#' @examples
#' # calcFinStat
#' FinStat <- calcFinStat(FinSeri,"mean")
calcFinStat <- function(FinSeri,stat=c('mean','sum','slope','slope/mean','slope/growthsd','sd','mean/sd'),fname,rm_N){
if(missing(fname)){
fname <- guess_factorNames(FinSeri,no_factorname = c("stockID", "rptDate","lagN","lag_rptDate","ipoDate"),is_factorname = "factorscore",silence = TRUE)
}
# melt & group_by
FinSeri <- reshape2::melt(FinSeri,measure.vars=fname,variable.name = "fname", value.name = "value")
FinSeri <- dplyr::group_by(FinSeri,fname,stockID,rptDate)
if(!missing(rm_N)){ # remove the too short seri
FinSeri <- FinSeri %>% dplyr::filter(n() > rm_N)
}
# get rptTS_stat
if(stat=="mean"){
rptTS_stat <- dplyr::summarise(FinSeri,value=mean(value,na.rm = TRUE))
} else if (stat=="sum"){
rptTS_stat <- dplyr::summarise(FinSeri,value=sum(value,na.rm = TRUE))
} else if (stat=="sd"){
rptTS_stat <- dplyr::summarise(FinSeri,value=sd(value,na.rm = TRUE))
} else if (stat=="mean/sd"){
rptTS_stat <- dplyr::summarise(FinSeri,value=mean(value,na.rm = TRUE)/sd(value,na.rm = TRUE))
} else if (stat %in% c("slope","slope/mean","slope/growthsd")){
FinSeri$lagN <- as.integer(substr(FinSeri$lagN,2,1000))
if(stat=="slope"){
rptTS_stat <- dplyr::do(FinSeri,mod = lm(value ~ lagN, data = .))
rptTS_stat <- broom::tidy(rptTS_stat,mod)
rptTS_stat <- rptTS_stat[rptTS_stat$term=='lagN',c("fname","stockID","rptDate","estimate")]
rptTS_stat <- renameCol(rptTS_stat,"estimate","value")
}else if(stat %in% c("slope/mean","slope/growthsd")){
if(stat=="slope/mean"){
rptTS_stat1 <- FinSeri %>% dplyr::summarise(value2=mean(value,na.rm = TRUE))
}else{
FinSeri <- FinSeri %>% dplyr::mutate(value2=value/dplyr::lead(value)-1)
FinSeri <- FinSeri %>% dplyr::filter(!is.na(value2))
rptTS_stat1 <- dplyr::summarise(FinSeri,value2=sd(value2,na.rm = TRUE))
}
rptTS_stat2 <- dplyr::do(FinSeri,mod = lm(value ~ lagN, data = .))
rptTS_stat2 <- broom::tidy(rptTS_stat2,mod)
rptTS_stat2 <- rptTS_stat2[rptTS_stat2$term=='lagN',c("fname","stockID","rptDate","estimate")]
rptTS_stat <- dplyr::left_join(rptTS_stat1,rptTS_stat2,by=c("fname","stockID","rptDate"))
rptTS_stat <- transform(rptTS_stat,value=estimate/value2,estimate=NULL,value2=NULL)
}
}
# cast
re <- reshape2::dcast(rptTS_stat,stockID+rptDate~fname)
return(re)
}
#' rptTS.getFinStat_ts
#'
#' @export
#' @examples
#' # rptTS.getFinStat_ts
#' FinStat <- rptTS.getFinStat_ts(rptTS,12,"q",'"np_belongto_parcomsh",report(46078,RDate)',stat="mean")
rptTS.getFinStat_ts <- function(rptTS, N, freq, funchar, varname,
stat=c('mean','sum','slope','slope/mean','slope/growthsd','sd','mean/sd'),
rm_N, ...){
stat <- match.arg(stat)
check.rptTS(rptTS)
FinSeri <- rptTS.getFinSeri_ts(rptTS = rptTS,N = N,freq = freq,funchar = funchar, varname = varname, ...)
rptTS_stat <- calcFinStat(FinSeri=FinSeri,stat = stat,fname = varname, rm_N = rm_N)
re <- merge.x(rptTS,rptTS_stat,by=c("stockID","rptDate"))
return(re)
}
# -------------------- ~~ TS.getFin_by_rptTS ----------------
#' getrptDate_newest
#'
#' get the newest rptDate of the stocks on specific dates.
#' @param TS a \bold{TS} object
#' @param stockID a vector of stockID
#' @param endT a vector of Date
#' @param mult a character string. Could be one of "last","first","all". IF a listed company publish more than one financial reports in a single day, which one should be returned? the newest one(the default value), the earliest one or all of them? See example for dedail.
#' @param drop a logical. Shoud the \code{TS} be exculded in the result?
#' @return a data.frame,with the same cols of TS,added by "\code{rptDate}". Or a vector if \code{drop} is TRUE.
#' @note param TS and combination of stockID and endT should at least have one and only have one. The combination of vector stockID and endT could be different length, which abide by the recycling rule.
#' @author Ruifei.Yin
#' @export
#' @examples
#' # - with TS
#' TS <- getTS(getRebDates(as.Date('2007-03-17'),as.Date('2012-05-20'),rebFreq="year"),'EI000300')
#' getrptDate_newest(TS)
#' # - one stock, multiple dates
#' getrptDate_newest(stockID="EQ000001", endT=seq(from=as.Date("2010-12-31"),to=as.Date("2011-12-31"),by="month"))
#' # - one date, multiple stocks
#' getrptDate_newest(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2003-04-30"))
#' # - multi="all"
#' getrptDate_newest(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2003-04-30"),mult="all")
#' # - multi="first"
#' getrptDate_newest(stockID=c("EQ000001","EQ000002","EQ000004"), endT=as.Date("2003-04-30"),mult="first")
getrptDate_newest <- function(TS,stockID,endT=Sys.Date(),freq=c("q","y","h"),
mult=c("last","first","all"),
drop=FALSE,
datasrc=defaultDataSRC()){
freq <- match.arg(freq)
mult <- match.arg(mult)
if (missing(TS) && missing(stockID)) {
stop("Param TS and combination of stockID and endT should at least have one!")
}
if (!missing(TS) && !missing(stockID)) {
stop("Param TS and combination of stockID and endT should only have one!")
}
if (missing(TS)){
TS <- data.frame(date=endT, stockID=stockID)
}
check.TS(TS)
if(datasrc %in% c("quant","local")){
TS_new <- TS
TS_new$date <- rdate2int(TS_new$date)
if(datasrc=="quant"){
qr <- "select a.date,a.stockID,
(select top 1 EndDate from LC_RptDate where stockID=a.stockID and PublDate<=a.date order by EndDate Desc ) as rptDate
from temp_table a"
con <- db.quant()
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=TS_new[,c("date","stockID")],tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr,stringsAsFactors=FALSE)
odbcClose(con)
} else if (datasrc=="local"){
qr <- "select a.date,a.stockID,
(select EndDate from LC_RptDate where stockID=a.stockID and PublDate<=a.date order by EndDate Desc limit 1) as rptDate
from temp_table a"
con <- db.local("main")
dbWriteTable(con,name="temp_table",value=TS_new[,c("date","stockID")],row.names = FALSE,overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re <- transform(re, date=intdate2r(date), rptDate=intdate2r(rptDate))
}else if(datasrc=='ts'){
dates <- unique(TS$date)
re <- data.frame(stringsAsFactors = FALSE)
for(i in 1:length(dates)){
TS_ <- TS[TS$date==dates[i],]
tsdate <- rdate2ts(dates[i])
funchar <- paste("'rptDate',NewReportDateOfEndT2(",tsdate,")",sep = '')
re_ <- ts.wss(TS_$stockID,funchar=funchar)
re_ <- re_ %>% dplyr::mutate(date=dates[i],rptDate=intdate2r(rptDate)) %>% dplyr::select(date,stockID,rptDate)
re <- rbind(re,re_)
}
}
if(freq %in% c("y","h")){ # get the newest yearly report or halfyearly report
re$rptDate <- rptDate.nearest(re$rptDate,freq = freq,dir = -1L)
}
re <- merge.x(TS,re,by=c("date","stockID"),mult=mult)
if(drop){
return(re[,"reptDate"])
} else {
return(re)
}
}
#' TS.getFin_by_rptTS
#'
#' get financial factorscore via rptTS
#' @param fun a function or a non-empty character string naming the function to be called, which get the financtial indicators from \bold{rptTS}. Note that the function must contain a param of 'rptTS' .
#' @param ... optional arguments except rptTS of fun.
#' @return a dataframe with the same length with TS, but added by some other financial indicator fields.
#' @export
#' @seealso \code{\link{rptTS.getFin_windR}}, \code{\link{rptTS.getFin_ts}}
#' @author Ruifei.Yin
#' @examples
#' TS <- Model.TS(modelPar.univ(indexID="ES09440000"))
#' re <- TS.getFin_by_rptTS(TS,fun="rptTS.getFin_windR",field="np_belongto_parcomsh","rptType=1")
#' re2 <- TS.getFin_by_rptTS(TS,fun="rptTS.getFin_ts",funchar='"np_belongto_parcomsh",report(46078,RDate)')
#' # -- Following is a speed comparison of three different methods to get financial factorscores:
#'
#' TS <- Model.TS(setmodelPar.time(modelPar.default(),begT=as.Date("2007-12-01"),endT=as.Date("2014-05-01")))
#' system.time(re.wind <- TS.getFin_by_rptTS(TS,fun="rptTS.getFin_windR",field="np_belongto_parcomsh","rptType=1")) # 73.69
#' system.time(re.ts_dir <- TS.getFin_ts(TS,funchar='report(46078,RDate)',varname="np_belongto_parcomsh")) # 12.49
#' system.time(re.ts_rpt <- TS.getFin_by_rptTS(TS,fun="rptTS.getFin_ts",funchar='"np_belongto_parcomsh",report(46078,RDate)')) # 6.29
TS.getFin_by_rptTS <- function(TS, fun, ...){
check.TS(TS)
TS <- getrptDate_newest(TS,mult="last")
rptTS <- unique(TS[, c("rptDate","stockID")])
rptTSF <- do.call(fun, list(rptTS=rptTS, ...))
TSF <- merge.x(TS, rptTSF, by=c("rptDate","stockID"))
return(TSF)
}
# -------------------- ~~ TSFR.rptTSF_nextF ----------------
#' TSFR.rptTSF_nextF
#'
#' @param funchar a tinysoft financial factor function string. Can be missing when ... arguments are passed, in this case, any 'gf.xx' function(not only financial factors) could be tested.
#' @param ... argument for \code{\link[QDataGet]{getTSF}}.
#' @return a \bold{TSFR} object,\code{date_end} represents next report date,\code{factorscore} represents factorscore of next report date.
#' @examples
#' begT <- as.Date("2007-12-31")
#' endT <- as.Date("2017-12-31")
#' univ <- "EI000985"
#' #- freq="y"
#' funchar <- '"factorscore",reportofall(9900100,RDate)' #ROE
#' funchar <- '"factorscore",reportofall(9900604,RDate)' #growth of net profit
#' funchar <- '"factorscore",reportofall(9900501,RDate)' #divdendyield
#' refinePar <- refinePar_default("none")
#' refinePar <- refinePar_default("scale_sec")
#' TSFR <- TSFR.rptTSF_nextF(begT,endT,freq="y",univ,funchar,refinePar)
#' #- freq="q"
#' funchar <- '"factorscore",LastQuarterData(RDate,9900604)'
#' TSFR <- TSFR.rptTSF_nextF(begT,endT,freq="q",univ,funchar,refinePar=refinePar_default("reg"))
#' #- funchar is missing
#' TSFR <- TSFR.rptTSF_nextF(begT,endT,freq="y",univ,factorFun='gf.PB_mrq', factorPar = list(fillna = TRUE))
#' @export
TSFR.rptTSF_nextF <- function(begT=as.Date("2007-12-31"),endT=as.Date("2016-12-31"),
freq='y',univ,funchar,refinePar=refinePar_default(),...){
#get report TS
rptDates <- rptDate.get(begT,endT,freq)
rptTS <- getrptTS(univ=univ,rptDates=rptDates)
rptTS <- rptDate.publ(rptTS)
rptTS <- rptTS %>% dplyr::filter(!is.na(PublDate)) %>% dplyr::select(-PublDate)
#get report TSF and refine
if(missing(funchar)){
TS <- rptTS %>% dplyr::rename(date=rptDate)
rptTSF <- getTSF(TS,...)
rptTSF <- rptTSF %>% dplyr::rename(rptDate=date)
}else{
rptTSF <- rptTS.getFin_ts(rptTS,funchar)
}
TSF <- rptTSF %>% dplyr::rename(date=rptDate)
TSF <- factor_refine(TSF,refinePar)
TSF <- TSF %>% dplyr::filter(!is.na(factorscore))
#get next period factorscore and refine
rptTS_ <- transform(rptTS,rptDate_end=rptDate.offset(rptDate,1,freq))
rptTS2 <- rptTS_ %>% dplyr::select(rptDate_end,stockID) %>%
dplyr::rename(rptDate=rptDate_end) %>% dplyr::setdiff(rptTS)
if(nrow(rptTS2)>0){
rptTS2 <- rptDate.publ(rptTS2)
rptTS2 <- rptTS2 %>% dplyr::filter(!is.na(PublDate)) %>% dplyr::select(-PublDate)
if(missing(funchar)){
TS2 <- rptTS2 %>% dplyr::rename(date=rptDate)
rptTSF2 <- getTSF(TS2,...)
rptTSF2 <- rptTSF2 %>% dplyr::rename(rptDate=date)
}else{
rptTSF2 <- rptTS.getFin_ts(rptTS2,funchar)
}
rptTSF <- rbind(rptTSF,rptTSF2)
}
TSF2 <- rptTSF %>% dplyr::arrange(rptDate,stockID) %>% dplyr::rename(date=rptDate)
TSF2 <- factor_refine(TSF2,refinePar)
TSF2 <- TSF2 %>% dplyr::filter(!is.na(factorscore)) %>% dplyr::rename(date_end=date,periodrtn=factorscore)
#get TSFR
rptTS_ <- rptTS_ %>% dplyr::rename(date=rptDate,date_end=rptDate_end)
TSFR <- TSF %>% dplyr::left_join(rptTS_,by=c('date','stockID')) %>%
dplyr::left_join(TSF2,by=c('date_end','stockID'))
return(TSFR)
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== Others =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' getTech
#'
#' @export
#' @rdname getTech
getTech <- function(TS,
variables = select.list(CT_TechVars(datasrc=datasrc,secuCate="EQ",tableName=tableName)[["varName"]],graphics=TRUE,multiple=TRUE),
tableName="QT_DailyQuote",
datelist,stockID,
drop,
datasrc=defaultDataSRC()){
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
missing_TS <- TRUE
} else {
missing_TS <- FALSE
}
re <- TS.getTech(TS=TS,variables = variables,tableName = tableName,datasrc = datasrc)
if(missing(drop)){
drop <- if(missing_TS&length(variables)==1) TRUE else FALSE
}
if(drop){
return(re[,variables])
}else{
return(re)
}
}
#' @rdname getTech
#' @export
TS.getTech <- function(TS,
variables = select.list(CT_TechVars(datasrc=datasrc,secuCate="EQ",tableName=tableName)[["varName"]],graphics=TRUE,multiple=TRUE),
tableName="QT_DailyQuote",
datasrc=defaultDataSRC()){
check.TS(TS)
tmpdat <- transform(TS[,c("stockID","date")], date = rdate2int(date))
tmpdat$PK_ <- 1:NROW(tmpdat)
vars <- CT_TechVars(datasrc=datasrc,secuCate="EQ",tableName=tableName,vars=variables)
if(NROW(vars)==0){
stop(paste("No fields matched in table",QT(tableName),"in datasrc",QT(datasrc),"!"))
}
vars <- paste(vars$func,"as",QT(vars$varName), collapse=", ")
qr <- paste("select a.*,",vars,"from temp_table a left join",tableName ,"b on a.stockID=b.ID and a.date=b.TradingDay")
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=tmpdat,tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- if(tableName =="QT_FactorScore"){
db.local("fs")
}else if(tableName =="QT_FactorScore_R"){
db.local("fs_r")
}else{
db.local("qt")
}
dbWriteTable(con,name="temp_table",value=tmpdat,row.names = FALSE,overwrite = TRUE)
if(tableName %in% c("QT_DailyQuote","QT_FactorScore","QT_FactorScore_R")){
dbExecute(con, 'CREATE INDEX [IX_temp_table] ON [temp_table]([date],[stockID]);')
}
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re <- dplyr::arrange(re,PK_)[,variables,drop=FALSE]
re <- cbind(TS,re)
return(re)
}
#' @export
#' @rdname getTech_ts
getTech_ts <- function(TS,funchar,varname=funchar, Rate=1, RateDay=0,
datelist,stockID,
drop){
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if(missing(drop)){
drop <- if(missing(TS)&length(funchar)==1) TRUE else FALSE
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
result <- TS.getTech_ts(TS=TS,funchar = funchar,varname = varname,Rate = Rate,RateDay = RateDay)
if(drop){
return(result[,varname])
}else{
return(result)
}
}
#' getTech_ts
#'
#' get technical factors throug a tinysoft expression, which could be a simple expresion, e.g 'close()','StockZf2(20)','BBIBOLL_v(11,6)',..,or more complicated expression, e.g. 'close()/open()', 'StockZf2(10)-StockZf2(20)'...
#' @param TS a \bold{TS} object
#' @param funchar a vector of character,the tinysoft function with the arguments. e.g \code{"BBIBOLL_v(11,6)"}
#' @param varname character string, giving the name of the returned variables
#' @return A \bold{TSF} object
#' @note Note that the tinysoft function must contain ONLY two(no more!) system parameters: pn_stock() and pn_date() ,which is specifyed by the two fields in the TS respectively.
#' @author Ruifei.Yin
#' @export
#' @rdname getTech_ts
#' @examples
#' TS <- getTS(getRebDates(as.Date('2011-03-17'),as.Date('2012-04-17')),'EI000300')
#' p1 <- 11
#' p2 <- 6
#' funchar <- paste('BBIBOLL_v(',p1,',',p2,')',sep='')
#' TSF <- TS.getTech_ts(TS,funchar)
#' TSF <- TS.getTech_ts(TS, funchar="StockAveHsl2(20)/StockAveHsl2(60)", varname="avgTurnover_1M3M")
#' funchar <- c('BBIBOLL_v(11,6)','StockAveHsl2(20)/StockAveHsl2(60)')
#' TSF2 <- TS.getTech_ts(TS, funchar)
TS.getTech_ts <- function(TS,funchar,varname=funchar, Rate=1, RateDay=0){
check.TS(TS)
tmpfile <- TS[,c('date','stockID')]
tmpfile$stockID <- stockID2stockID(tmpfile$stockID,from="local",to="ts")
tmpfile$date <- as.character(tmpfile$date)
tmpcsv <- tempfile(fileext=".csv")
tmpcsv2 <- stringr::str_replace_all(tmpcsv,'\\\\',"\\\\\\\\")
write.csv(tmpfile,tmpcsv,row.names=FALSE,quote=FALSE)
subqr <- ""
for( i in 1:length(funchar)){
subqr <- paste0(subqr, ' factorexp[',i-1,'] := &"',funchar[i],'"; ')
}
subqr2 <- ""
if(!is.null(Rate)){
subqr2 <- paste0(subqr2, ' SetSysParam(pn_rate(), ',Rate,'); ')
}
if(!is.null(RateDay)){
subqr2 <- paste0(subqr2, ' SetSysParam(pn_rateday(), ',RateDay,'); ')
}
len.funchar <- length(funchar)-1
qrstr <- paste0('oV:=BackUpSystemParameters();
SetSysParam(pn_cycle(),cy_day());
',subqr2,'
rdo2 importfile(ftcsv(),"","',tmpcsv2,'",timestockframe);
factorexp := array();
',subqr,'
result:=array();
for i:=0 to length(timestockframe)-1 do
begin
SetSysParam(pn_stock(),timestockframe[i]["stockID"]);
SetSysParam(pn_date(),strtodate(timestockframe[i]["date"]));
for j:= 0 to ',len.funchar,' do
begin
factorvalue:=eval(factorexp[j]);
result[i][j]:=factorvalue;
end;
end;
RestoreSystemParameters(oV);
return result;')
tsRequire()
fct <- tsRemoteExecute(qrstr)
fct <- plyr::ldply(fct, unlist)
colnames(fct) <- varname
result <- cbind(TS,fct)
return(result)
}
#' @export
#' @rdname getFin_ts
getFin_ts <- function(TS,funchar,varname=funchar,Rate=1,RateDay=0,
datelist,stockID,
drop){
if (missing(TS) && any(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should at least have one!")
}
if (!missing(TS) && !all(missing(stockID),missing(datelist))) {
stop("Param TS and combination of stockID and datelist should only have one!")
}
if(missing(drop)){
drop <- if(missing(TS)&length(funchar)==1) TRUE else FALSE
}
if (missing(TS)){
TS <- expand.grid(date=datelist, stockID=stockID)
}
result <- TS.getFin_ts(TS=TS,funchar = funchar,varname = varname,Rate = Rate,RateDay = RateDay)
if(drop){
return(result[,varname])
}else{
return(result)
}
}
#' getFin_ts
#'
#' get financial factors throug a tinysoft expression, which could be simple or more complicated.
#'
#' Note that the tinysoft function must contain ONLY two system parameters(no more!):pn_stock() and pn_date() ,which is supplyed from the two fields in the TS respectively.Also,the function must contain a expression of 'Rdate:=NewReportDateOfEndT2(sp_time())' to get the newest Rdate of sp_time.
#' @param TS a \bold{TS} object
#' @param funchar a vector of character string, giving a tinysoft expression to get the financtial indicators of the stock. The expression can be made simply by replaceing the specified reportdate in the stock-data-expert expression by \code{'Rdate'}. e.g. change \code{Last12MData(20091231,46002)} to \code{Last12MData(Rdate,46002)}.
#' @param varname character string, giving the name of the returned variables
#' @return A \bold{TSF} object,a dataframe, containing at least cols:\bold{date}(with class of Date),\bold{stockID},\bold{varname},\bold{Rdate}
#' @note Note that the tinysoft function must contain ONLY two system parameters(no more!):pn_stock() and pn_date() ,which is supplyed from the two fields in the TS respectively. Also,the function must contain a expression of 'Rdate:=NewReportDateOfEndT2(sp_time())' to get the newest Rdate of sp_time.
#' @author Ruifei.Yin
#' @export
#' @rdname getFin_ts
#' @examples
#' TS <- getTS(getRebDates(as.Date('2011-03-17'),as.Date('2012-04-17')),'EI000300')
#' TSF <- TS.getFin_ts(TS,"ReportOfAll(9900416,Rdate)")
#' TSF2 <- TS.getFin_ts(TS,"GrowthOfNReport(@@LastQuarterData(DefaultRepID(),9900003,0),Rdate,3,1)")
#' TSF3 <- TS.getFin_ts(TS,"StockAveHsl2(20)+reportofall(9900003,Rdate)")
#' funchar <- c("ReportOfAll(9900416,Rdate)","StockAveHsl2(20)+reportofall(9900003,Rdate)")
#' TSF4 <- TS.getFin_ts(TS, funchar)
TS.getFin_ts <- function(TS,funchar,varname=funchar,Rate=1,RateDay=0){
check.TS(TS)
tmpfile <- TS[,c('date','stockID')]
tmpfile$stockID <- stockID2stockID(tmpfile$stockID,from="local",to="ts")
tmpfile$date <- as.character(tmpfile$date)
tmpcsv <- tempfile(fileext=".csv")
tmpcsv2 <- stringr::str_replace_all(tmpcsv,'\\\\',"\\\\\\\\")
write.csv(tmpfile,tmpcsv,row.names=FALSE,quote=FALSE)
subqr <- ""
for( i in 1:length(funchar)){
subqr <- paste0(subqr, ' factorexp[',i-1,'] := &"',funchar[i],'"; ')
}
subqr2 <- ""
if(!is.null(Rate)){
subqr2 <- paste0(subqr2, ' SetSysParam(pn_rate(), ',Rate,'); ')
}
if(!is.null(RateDay)){
subqr2 <- paste0(subqr2, ' SetSysParam(pn_rateday(), ',RateDay,'); ')
}
len.funchar <- length(funchar)-1
qrstr <- paste0('oV:=BackUpSystemParameters();
SetSysParam(pn_cycle(),cy_day());
',subqr2,'
rdo2 importfile(ftcsv(),"","',tmpcsv2,'",timestockframe);
factorexp := array();
',subqr,'
result:=array();
for i:=0 to length(timestockframe)-1 do
begin
SetSysParam(pn_stock(),timestockframe[i]["stockID"]);
SetSysParam(pn_date(),strtodate(timestockframe[i]["date"]));
Rdate:=NewReportDateOfEndT2(sp_time());
for j:=0 to ',len.funchar,' do
begin
factorvalue:=eval(factorexp[j]);
result[i][j]:=factorvalue;
end;
result[i]["Rdate"]:=Rdate;
end;
RestoreSystemParameters(oV);
return result;')
tsRequire()
fct <- tsRemoteExecute(qrstr)
fct <- plyr::ldply(fct,as.data.frame)
colnames(fct) <- c(varname, "RDate")
result <- cbind(TS,fct)
return(result)
}
#' getQuote_ts
#'
#' get Quote series of some stocks in certain period
#' @param stocks a vector of charactor
#' @param begT an object of class "Date"
#' @param endT an object of class "Date"
#' @param variables a vector of charactor,elements of which could be stockID,stockName,date,price,open,high,low,vol,amount,yclose,sectional_yclose,cjbs,...
#' @param Cycle a charactor string,eg."cy_day()","cy_30m()","cy_month()",...
#' @param Rate a integer,giving the type of rights adjustment, could be one of 0(no adjustment),1(geometric adjustment),2(simple adjustment),3
#' @param RateDay a integer,giving the base date of right adjustment,could be one of 0(the last trading day),-1(the IPO date),or a tinysoft date integer(eg.\code{rdate2ts(as.Date("2010-01-02"))})
#' @param melt a logical. If FALSE(default), the style of result is "stockID+date~variable";If TRUE, the quote data will be melted(see the examples for details).
#' @param split logical.
#' @param splitNbin integer.
#' @return the quote data, a data frame object with cols:stockID,stockName,date(\bold{of class POSIXct}) and the elements the param \code{variable} containing
#' @export
#' @author Ruifei.Yin
#' @examples
#' stocks <- c("SZ002001","SZ002002")
#' begT <- as.Date("2011-01-01")
#' endT <- as.Date("2011-02-01")
#' variables <- c("price","open")
#' qt.asis <- getQuote_ts(stocks,begT,endT,variables)
#' qt.melt <- getQuote_ts(stocks,begT,endT,variables,melt=TRUE)
getQuote_ts <- function(stocks,begT,endT,variables,Cycle="cy_day()",Rate=0,RateDay=0,melt=FALSE,
split = if(length(stocks) > splitNbin) TRUE else FALSE,
splitNbin = 50){
# stocks <- c("SZ002001","SZ002002")
# begT <- as.Date("2008-01-01")
# endT <- as.Date("2011-02-01")
# variables <- c("price","yclose")
# Cycle="cy_day()"
# Rate=0
# RateDay=0
subfun <- function(stocks,begT,endT,variables,Cycle,Rate,RateDay,melt){
stockID <- paste(stocks,collapse=",")
begT <- rdate2ts(begT)
endT <- rdate2ts(endT)
variables <- paste('["',variables,'"]',sep="",collapse=",")
tsRequire()
qt <- tsRemoteCallFunc("getQuote",list(stockID,begT,endT,variables,Cycle,Rate,RateDay))
qt <- plyr::ldply(qt,as.data.frame)
qt$date <- as.POSIXct(qt$date,tz="")
if(melt){
qt <- reshape2::melt(qt,id.vars=c("stockID","date"))
}
return(qt)
}
if(!split){
re <- subfun(stocks,begT,endT,variables,Cycle,Rate,RateDay,melt)
} else {
Ngroup <- length(stocks) %/% splitNbin +1
Ngroup <- if(Ngroup>1) Ngroup else Ngroup+1
bby <- cut(1:length(stocks),Ngroup,labels=FALSE)
warning(paste('Possibly dealing with a big quote data. The process is split to ',Ngroup,'groups.'))
for(i in 1:Ngroup){
# i <- 2
substocks <- stocks[bby==i]
message("Dealing with ",i," of ",Ngroup,"groups ... ")
gc()
qt <- subfun(substocks,begT,endT,variables,Cycle,Rate,RateDay,melt)
if(i==1L){
re <- qt
} else {
re <- rbind(re,qt)
}
}
}
return(re)
}
#' getQuote
#'
#' get Quote series of stocks, indexs, futures in certain period
#' @aliases getQuote getIndexQuote getIFquote
#' @param stocks a charactor vector of stockID or indexID.
#' @param begT an object of class "Date"
#' @param endT an object of class "Date"
#' @param variables a vector of charactor. Call funtion \code{CT_TechVars(secuCate="EQ")} to get all available variables of equity, funtion \code{CT_TechVars(secuCate="EI")} of equity index, and funtion \code{CT_TechVars(secuCate="IF")} of index future.
#' @param melt a logical. If FALSE(default), the style of result is "stockID+date~variable";If TRUE, the quote data will be melted(see the examples for details).
#' @param split logical
#' @param splitNbin an interval specification, one of "day", "week", "month", "quarter" and "year", optionally preceded by an integer and a space, or followed by "s". See \code{\link{cut.Date}} for detail.
#' @param tableName character string, giving the table name from which get data.
#' @return the quote data, a data frame object with cols:stockID,date and the elements the param \code{variable} containing. If melt is TRUE, data frame with cols:stockID,date,variable,value
#' @export
#' @author Ruifei.Yin
#' @examples
#' # get stock's quote
#' stocks <- c("EQ002001","EQ002002")
#' begT <- as.Date("2007-01-01")
#' endT <- as.Date("2013-02-01")
#' variables <- c("close","pct_chg","vwap")
#' re <- getQuote(stocks,begT,endT,variables,datasrc="local")
#' re <- getQuote(stocks,begT,endT,variables,melt=TRUE,datasrc="local")
#' stocks <- getIndexComp("EI000300")
#' system.time(uu2 <- getQuote(stocks,begT,endT,variables,datasrc="local",split=FALSE))
#' system.time(uu1 <- getQuote(stocks,begT,endT,variables,datasrc="local",split=TRUE))
getQuote <- function(stocks, begT=as.Date("1990-12-19"), endT=Sys.Date(),
variables = select.list(CT_TechVars(datasrc=datasrc,secuCate="EQ",tableName=tableName)[["varName"]],graphics=TRUE,multiple=TRUE),
melt=FALSE,
split,
splitNbin = 'year',
tableName = "QT_DailyQuote",
datasrc=defaultDataSRC()){
if(begT>endT){
stop(paste("begT ",begT,"is later then endT ",endT))
}
techVars <- CT_TechVars(datasrc=datasrc,secuCate="EQ",tableName=tableName,vars=variables)
if(NROW(techVars)==0){
stop(paste("No fields matched in ",tableName," in datasrc",QT(datasrc),"!"))
}
vars_as <- paste(techVars$func,"as",QT(techVars$varName), collapse=", ")
vars_new <- paste(techVars$varName,collapse=",")
dates <- data.frame(date=getRebDates(begT,endT,rebFreq = 'day'))
dates <- dates %>% dplyr::filter(date>=begT,date<=endT) %>%
dplyr::mutate(splitday=as.Date(cut.Date2(date,splitNbin)),date=rdate2int(date))
splitdays <- unique(dates$splitday)
if(missing(split)){
if(length(splitdays)>1){
split <- TRUE
}else{
split <- FALSE
}
}
stockdf <- data.frame(stockID=stocks,stringsAsFactors = FALSE)
stockdf <- stockdf %>% dplyr::mutate(InnerCode=stockID2stockID(stockID,from = 'local',to = 'jy'),
ipoday=rdate2int(trday.IPO(stockID)))
ts <- expand.grid(date=dates$date,InnerCode=stockdf$InnerCode, KEEP.OUT.ATTRS = FALSE, stringsAsFactors = FALSE)
ts <- ts %>% dplyr::left_join(stockdf,by='InnerCode') %>%
dplyr::filter(date>=ipoday) %>%
dplyr::select(-ipoday)
if(datasrc=='local'){
con <- db.local("qt")
subfun_local <- function(TS,melt){
dbWriteTable(con,name="temp_table",value=TS,row.names = FALSE,overwrite = TRUE)
dbExecute(con, 'CREATE INDEX [IX_temp_table] ON [temp_table] ([date],[InnerCode]);')
querychar <- paste("select a.stockID,a.date,",vars_new,"from temp_table a inner join
(select TradingDay,InnerCode,",vars_as,
"from ",tableName," where TradingDay>=",min(TS$date)," and TradingDay<=",max(TS$date),") b
on a.date=b.TradingDay and a.InnerCode=b.InnerCode")
qt <- dbGetQuery(con,querychar)
qt$date <- intdate2r(qt$date)
if(melt){
qt <- reshape2::melt(qt,id.vars=c("stockID","date"))
}
return(qt)
}
if(!split){
re <- subfun_local(ts,melt)
}else{
ts <- ts %>% dplyr::left_join(dates,by='date')
warning(paste('Possibly dealing with a big data. The process is splited to ',length(splitdays),'groups.'))
re <- data.frame(stringsAsFactors = FALSE)
for(i in 1:length(splitdays)){
ts_ <- ts %>% dplyr::filter(splitday==splitdays[i]) %>% dplyr::select(-splitday)
cat("Dealing with ",i," of ",length(splitdays),"groups ... \n")
gc()
re_ <- subfun_local(ts_,melt)
re <- rbind(re,re_)
}
}
dbDisconnect(con)
}else if(datasrc=="quant"){
con <- db.quant()
subfun_quant <- function(stockID,begT,endT,melt){
querychar <- paste("select ID as stockID,TradingDay as date,",vars_as,
"from ",tableName," where ID in",
brkQT(stockID)," and TradingDay >=", begT, " and TradingDay <=",endT)
qt <- sqlQuery(con,querychar,as.is=FALSE,stringsAsFactors = FALSE)
qt$date <- intdate2r(qt$date)
if(melt){
qt <- reshape2::melt(qt,id.vars=c("stockID","date"))
}
return(qt)
}
if(!split){
re <- subfun_quant(stockdf$stockID,rdate2int(begT),rdate2int(endT),melt)
}else{
ts <- ts %>% dplyr::left_join(dates,by='date')
warning(paste('Possibly dealing with a big data. The process is splited to ',length(splitdays),'groups.'))
re <- data.frame(stringsAsFactors = FALSE)
for(i in 1:length(splitdays)){
ts_ <- ts %>% dplyr::filter(splitday==splitdays[i]) %>% dplyr::select(-splitday)
cat("Dealing with ",i," of ",length(splitdays),"groups ... \n")
gc()
re_ <- subfun_quant(stockdf$stockID,min(ts_$date),max(ts_$date),melt)
re <- rbind(re,re_)
}
}
re <- dplyr::arrange(re,date,stockID)
odbcClose(con)
}
return(re)
}
#' @rdname getQuote
#' @export
#' @examples
#' # get index quote
#' indexs <- c("EI000001","EI000300")
#' begT <- as.Date("2015-01-01")
#' endT <- as.Date("2016-08-01")
#' variables <- c("close","pct_chg")
#' re <- getIndexQuote(indexs,begT,endT,variables,datasrc="local")
#' re <- getIndexQuote(indexs,begT,endT,variables,datasrc="jy")
getIndexQuote <- function(stocks,
begT=as.Date("1990-12-19"), endT=Sys.Date(),
variables = select.list(CT_TechVars(datasrc=datasrc,secuCate="EI",tableName="QT_IndexQuote")[["varName"]],graphics=TRUE,multiple=TRUE),
melt=FALSE,
datasrc=defaultDataSRC()){
begT <- rdate2int(begT)
endT <- rdate2int(endT)
vars <- CT_TechVars(datasrc=datasrc,secuCate="EI",tableName="QT_IndexQuote",vars=variables)
if(NROW(vars)==0){
stop(paste("No fields matched in table 'QT_IndexQuote' in datasrc",QT(datasrc),"!"))
}
subfun <- function(stocks,melt){
stocks_char <- paste("(",paste(QT(stocks),collapse=","),")",sep="")
vars <- paste(vars$func,"as",QT(vars$varName), collapse=", ")
querychar <- paste("select ID as stockID,TradingDay as date,",vars,"from QT_IndexQuote where ID in", stocks_char, "and TradingDay >=", begT, "and TradingDay <=" ,endT)
if(datasrc=="quant"){
con <- db.quant()
qt <- queryAndClose.odbc(db.quant(),querychar)
} else if(datasrc=="local"){
qt <- queryAndClose.dbi(db.local("main"),querychar)
}else if(datasrc=="jy"){
stocks_char <- brkQT(substring(stocks,3))
begT <- intdate2r(begT)
endT <- intdate2r(endT)
querychar <- paste("SELECT 'EI'+s.SecuCode 'stockID',CONVERT(varchar,TradingDay,112) 'date',",
vars," FROM QT_IndexQuote q,SecuMain s
where q.InnerCode=s.InnerCode and s.SecuCode in",stocks_char,
" and q.TradingDay>=",QT(begT)," and q.TradingDay<=",QT(endT))
qt <- queryAndClose.odbc(db.jy(),querychar)
qt <- dplyr::arrange(qt,stockID,date)
}
qt$date <- intdate2r(qt$date)
if(melt){
qt <- reshape2::melt(qt,id.vars=c("stockID","date"))
}
return(qt)
}
re <- subfun(stocks,melt)
return(re)
}
#' getPeriodrtn
#'
#' get the period return of the stocks
#' @param SP a \bold{SP} object ('stock*period'): a data frame with cols: "stockID","begT","endT"(with class of Date).
#' @param stockID a vector of stockID
#' @param begT a vector of Date
#' @param endT a vector of Date
#' @param tradeType a character string("close","nextavg","nextopen"),indicating the trading type.
#' @param drop a logical. If the \code{SP} shoud be exculded in the result?
#' @return a data frame, with cols of SP and "periodrtn". Or a vector if \code{drop} is TRUE.
#' @note param SP and combination of stockID, begT and endT should at least have one and only have one. The combination of vector stockID, begT and endT could be different length, which abide by the recycling rule.
#' @author Ruifei.Yin
#' @export
#' @examples
#' # -- with SP
#' getPeriodrtn(data.frame(stockID="EQ601313",begT=as.Date("2012-01-20"),endT=as.Date("2012-09-27")))
#' getPeriodrtn(data.frame(stockID="EQ601313",begT=as.Date("2012-01-20"),endT=as.Date("2012-09-27")),tradeType="nextopen")
#' TS <- getTS(getRebDates(as.Date('2007-03-17'),as.Date('2012-05-20')),'EI000300')
#' TS <- renameCol(TS,"date","begT")
#' SP <- data.frame(TS,endT=trday.offset(TS$begT,months(1)))
#' system.time(re <- getPeriodrtn(SP,datasrc="ts")) # 8.40
#' system.time(re1 <- getPeriodrtn(SP,datasrc="local")) # 1.94
#' system.time(re <- getPeriodrtn(SP,tradeType = "nextavg",datasrc="ts")) # 10.80
#' system.time(re1 <- getPeriodrtn(SP,tradeType = "nextavg",datasrc="local")) # 16.7
#'
#' #-- with combination of vector stockID, begT and endT
#' getPeriodrtn(stockID="EQ000001",begT=as.Date("2012-01-01"), endT=as.Date("2012-01-01")+c(10,20,30))
#' getPeriodrtn(stockID=c("EQ000001","EQ000002","EQ000004"),begT=as.Date("2012-01-01"), endT=as.Date("2013-01-01"))
getPeriodrtn <- function(SP, stockID, begT, endT,
tradeType=c("close","nextavg","nextopen"),drop=FALSE,
datasrc=defaultDataSRC()){
tradeType <- match.arg(tradeType)
if (missing(SP) && any(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should at least have one!")
}
if (!missing(SP) && !all(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should only have one!")
}
if (missing(SP)){
SP <- data.frame(stockID=stockID,begT=begT,endT=endT)
}
check.SP(SP)
if("periodrtn" %in% names(SP)){
warning("Column 'periodrtn' is already exist. It will be drop!")
SP$periodrtn <- NULL
}
if(datasrc=="ts"){
tmpdat <- transform(SP, stockID = stockID2stockID(stockID,from="local",to="ts"),
begT = as.character(begT),
endT = as.character(endT))
tmpcsv <- tempfile(fileext=".csv")
write.csv(tmpdat,tmpcsv,row.names=FALSE,quote=FALSE,fileEncoding="GB2312")
tsRequire()
periodrtn <- tsRemoteCallFunc("getperiodrtn",list(tmpcsv,tradeType))
periodrtn <- plyr::laply(periodrtn,as.array)
re <- cbind(SP, periodrtn)
}
if(datasrc %in% c("quant","local")){
# -- deal with the trading days
if(tradeType=="close"){
tmpdat <- transform(SP[,c("stockID","begT","endT")], begT = trday.nearest(begT), endT = trday.nearest(endT))
tmpdat <- transform(tmpdat, begT = rdate2int(begT), endT = rdate2int(endT))
tmpdat$PK_ <- 1:NROW(tmpdat)
} else {
begT_ <- trday.nearby(TS = dplyr::select(SP,date=begT,stockID),by = 1,drop = TRUE)
endT_ <- trday.nearby(TS = dplyr::select(SP,date=endT,stockID),by = 1,drop = TRUE)
tmpdat <- data.frame(stockID=SP$stockID,begT=begT_,endT=endT_)
tmpdat <- transform(tmpdat, begT = rdate2int(begT), endT = rdate2int(endT))
tmpdat$PK_ <- 1:NROW(tmpdat)
}
# -- query
if(tradeType=="close"){
qr <- "select a.*,b.RRClosePrice as P0,c.RRClosePrice as P1
from temp_table a left join QT_DailyQuote b
on a.begT=b.TradingDay and a.stockID=b.ID
left join QT_DailyQuote as c
on a.endT=c.TradingDay and a.stockID=c.ID"
} else if(tradeType=="nextopen"){
qr <- "select a.*,(b.OpenPrice*b.RRFactor) as P0,(c.OpenPrice*c.RRFactor) as P1
from temp_table a left join QT_DailyQuote b
on a.begT=b.TradingDay and a.stockID=b.ID
left join QT_DailyQuote as c
on a.endT=c.TradingDay and a.stockID=c.ID"
} else if(tradeType=="nextavg"){
qr <- "select a.*,(b.TurnoverValue/b.TurnoverVolume*b.RRFactor) as P0,
(c.TurnoverValue/c.TurnoverVolume*c.RRFactor) as P1
from temp_table a left join QT_DailyQuote b
on a.begT=b.TradingDay and a.stockID=b.ID
left join QT_DailyQuote as c
on a.endT=c.TradingDay and a.stockID=c.ID"
}
# -- fetch
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=tmpdat,tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("qt")
dbWriteTable(con,name="temp_table",value=tmpdat,row.names = FALSE,overwrite = TRUE)
dbExecute(con, 'CREATE INDEX [IX_temp_table] ON [temp_table]([begT],[stockID]);')
dbExecute(con, 'CREATE INDEX [IX2_temp_table] ON [temp_table]([endT],[stockID]);')
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re <- dplyr::arrange(re,PK_)[,c("P0","P1")]
re <- re$P1/re$P0-1
re <- cbind(SP,periodrtn=re)
}
if(drop){
return(re[,"periodrtn"])
} else {
return(re)
}
}
#' @rdname getPeriodrtn
#' @export
#' @examples
#' # -- getPeriodrtn_EI
#' getPeriodrtn_EI(stockID="EI000300",begT=as.Date("2012-01-01"), endT=as.Date("2012-01-01")+c(10,20,30))
getPeriodrtn_EI <- function(SP, stockID, begT, endT, drop=FALSE,
datasrc=defaultDataSRC()){
if (missing(SP) && any(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should at least have one!")
}
if (!missing(SP) && !all(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should only have one!")
}
if (missing(SP)){
SP <- data.frame(stockID=stockID,begT=begT,endT=endT)
}
check.SP(SP)
if(datasrc=="ts"){
tmpdat <- transform(SP, stockID = stockID2stockID(stockID,from="local",to="ts"),
begT = as.character(begT),
endT = as.character(endT))
tmpcsv <- tempfile(fileext=".csv")
write.csv(tmpdat,tmpcsv,row.names=FALSE,quote=FALSE,fileEncoding="GB2312")
tsRequire()
periodrtn <- tsRemoteCallFunc("getperiodrtn",list(tmpcsv,"close"))
periodrtn <- plyr::laply(periodrtn,as.array)
re <- cbind(SP, periodrtn)
}
if(datasrc %in% c("quant","local")){
# -- deal with the trading days
if(TRUE){
tmpdat <- transform(SP[,c("stockID","begT","endT")], begT = trday.nearest(begT), endT = trday.nearest(endT))
tmpdat <- transform(tmpdat, begT = rdate2int(begT), endT = rdate2int(endT))
tmpdat$PK_ <- 1:NROW(tmpdat)
}
# -- query
if(TRUE){
qr <- "select a.*,b.ClosePrice as P0,c.ClosePrice as P1
from temp_table a left join QT_IndexQuote b
on a.begT=b.TradingDay and a.stockID=b.ID
left join QT_IndexQuote as c
on a.endT=c.TradingDay and a.stockID=c.ID"
}
# -- fetch
if(datasrc=="quant"){
con <- db.quant()
sqlDrop(con,sqtable="temp_table",errors=FALSE)
sqlSave(con,dat=tmpdat,tablename="temp_table",safer=FALSE,rownames=FALSE)
re <- sqlQuery(con,query=qr)
odbcClose(con)
} else if (datasrc=="local"){
con <- db.local("main")
dbWriteTable(con,name="temp_table",value=tmpdat,row.names = FALSE,overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
}
re <- dplyr::arrange(re,PK_)[,c("P0","P1")]
re <- re$P1/re$P0-1
re <- cbind(SP,periodrtn=re)
}
if(drop){
return(re[,"periodrtn"])
} else {
return(re)
}
}
#' @rdname getPeriodrtn
#' @export
#' @examples
#' # -- getPeriodrtn_FU
#' getPeriodrtn_FU(stockID="FUIF00",begT=as.Date("2012-01-01"), endT=as.Date("2012-01-01")+c(10,20,30))
getPeriodrtn_FU <- function(SP, stockID, begT, endT, drop=FALSE,
datasrc="ts"){
if (missing(SP) && any(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should at least have one!")
}
if (!missing(SP) && !all(missing(stockID),missing(begT),missing(endT))) {
stop("Param SP and combination of stockID, begT and endT should only have one!")
}
if (missing(SP)){
SP <- data.frame(stockID=stockID,begT=begT,endT=endT)
}
check.SP(SP)
if(datasrc=="ts"){# todo
# tmpdat <- transform(SP, stockID = stockID2stockID(stockID,from="local",to="ts"),
# begT = as.character(begT),
# endT = as.character(endT))
# tmpcsv <- tempfile(fileext=".csv")
# write.csv(tmpdat,tmpcsv,row.names=FALSE,quote=FALSE,fileEncoding="GB2312")
# periodrtn <- tsRemoteCallFunc("getperiodrtn",list(tmpcsv,"close"))
# periodrtn <- plyr::laply(periodrtn,as.array)
# re <- cbind(SP, periodrtn)
}
if(datasrc %in% c("quant","local")){
}
if(drop){
return(re[,"periodrtn"])
} else {
return(re)
}
}
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
# =============== gf.xx functions =========
# ===================== xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx ==============
#' gf_cap
#' @param bc_lambda NULL, "auto", or a specific numeric.
#' @export
#' @examples
#' system.time(re <- gf_cap(ts,datasrc = "local"))
#' system.time(re2 <- gf_cap(ts,datasrc = "memory"))
gf_cap <- function(TS,
log=FALSE,
bc_lambda = NULL,
var=c("float_cap","mkt_cap","free_cap"),
na_fill=TRUE,
varname="factorscore",
datasrc="memory"){
var <- match.arg(var)
# shrink columns, merge back later
TS_core <- TS[,c("date","stockID")]
# retrieve data
if(datasrc=="local"){
if(var=="free_cap"){
re <- gf.free_float_sharesMV(TS_core)
re <- renameCol(re,"factorscore","cap")
} else {
re <- getTech(TS_core,variables=var)
re <- renameCol(re,var,"cap")
re$cap <- re$cap/10000 # 100 million ("yi")
}
} else if(datasrc=="memory"){
memory.load()
TS_core_DT <- data.table(TS_core, key = c("stockID","date"))
marketsize_DT <- data.table(.marketsize, key = c("stockID","date"))
re <- marketsize_DT[TS_core_DT, roll = TRUE]
re <- re[, c("date","stockID",var), with = FALSE]
colnames(re) <- c("date","stockID","cap")
re <- as.data.frame(re)
}
if(log){
re$cap <- log(re$cap)
}
if(!is.null(bc_lambda)){
re <- factor_bcPower(re, fname = "cap", lambda = bc_lambda)
}
if(na_fill){
re[is.na(re$cap),"cap"] <- median(re$cap, na.rm = TRUE)
}
re <- renameCol(re,"cap",varname)
# merge back
re <- merge.x(TS, re, by = c("date","stockID"))
return(re)
}
#' fl_cap
#' @export
fl_cap <- function(log=FALSE,bc_lambda=NULL,var="float_cap",na_fill=TRUE,datasrc="memory"){
re <- list(
factorFun = "gf_cap",
factorPar = list(log=log, bc_lambda=bc_lambda, var=var, na_fill=na_fill,datasrc=datasrc),
factorDir = 1 ,
factorRefine = list(
outlier=list(method = "none", par=NULL, sectorAttr= NULL),
std=list(method = "none", log=FALSE, sectorAttr=NULL, regLists=NULL),
na=list(method = "none", sectorAttr=NULL)
),
factorName = if(log) "ln_cap" else "cap",
factorID = "",
factorType = "",
factorDesc = ""
)
return(re)
}
#' gf.free_float_shares
#' @export
gf.free_float_shares <- function(TS){
check.TS(TS)
qr <- "select b.date, b.stockID,a.freeShares as 'factorscore'
from QT_FreeShares a, temp_table b
where a.rowid=(
select rowid from QT_FreeShares
where stockID=b.stockID and date<=b.date
order by date desc limit 1)"
TS$date <- rdate2int(TS$date)
con <- db.local("main")
dbWriteTable(con,name="temp_table",value=TS[,c("date","stockID")],row.names = FALSE,overwrite = TRUE)
re <- dbGetQuery(con,qr)
dbDisconnect(con)
re <- merge.x(TS[,c("date","stockID")],re,by=c("date","stockID"))
re <- transform(re, date=intdate2r(date))
return(re)
}
#' gf.free_float_sharesMV
#' @export
gf.free_float_sharesMV <- function(TS){
check.TS(TS)
ffs <- gf.free_float_shares(TS[,c('date','stockID')])
ffs <- renameCol(ffs,'factorscore','ffshares')
close <- getTech(TS[,c('date','stockID')],variables='close')
re <- merge.x(ffs,close,by=c('date','stockID'))
re <- transform(re,factorscore=ffshares*close)
re <- re[,c("date","stockID","factorscore")]
return(re)
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.