R/stock-db.R

Defines functions fetch_stock_field_dataset get_stock_field_dataset stocks_excess_return get_assets_return stock_db

Documented in get_assets_return stock_db stocks_excess_return

# setClassUnion("optionalList", c("list", "NULL"))

# Class definition of stock_db class -------------------------------

# Abstract Class of StockDB
# setClassUnion("ANYOrNull", c("ANY", "NULL"))
setRefClass("stock_db",
  fields = list(
    dsn = "character",
    connection = "ANY"
  ),
  contains = "VIRTUAL"
)

#' subclass object factory of stock_db class
#'
#' factory for creating for subclass object of stock_db class
#'
#' @param stock_db_class   Specific creator of stock database class,
#'   e.g. gta_db
#' @param ... Addition params used by specific class of stock database
#'      (e.g. a dsn string "GTA_SQLData").
#'
#' @return A object of stock db.
#' @export
#'
#' @examples
#' \dontrun{
#' library(zstmodelr)
#' stock_db <- stock_db(gta_db, "GTA_SQLData")
#' open_stock_db(stock_db)
#' close_stock_db(stock_db)
#' }
stock_db <- function(stock_db_class, ...) {

  # build class object
  class_object <- stock_db_class(...)

  return(class_object)
}

# Generic functions for stock_db operation ---------------------------------

#' Generic function for stock_db
#'
#' Generic function of operating stock database
#'
#' A group generic function to deal with a stock_db object
#'
#' @name stock_db_operation
#' @examples
#' \dontrun{
#' library(zstmodelr)
#' stock_db <- stock_db(gta_db, "GTA_SQLData")
#' open_stock_db(stock_db)
#' close_stock_db(stock_db)
#' }
NULL


#' Open stock database
#'
#' Generic function to open a stock database
#'
#' @param stock_db A stock database object to operate.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#' @return TRUE if succeed otherwise FALSE
#' @export
#' @examples
#' \dontrun{
#' library(zstmodelr)
#' stock_db <- stock_db(gta_db, "GTA_SQLData")
#' open_stock_db(stock_db)
#' close_stock_db(stock_db)
#' }
#'
#' # S3 generic definition
#' # open_stock_db <- function(stock_db, ...) {
#' #   UseMethod("open_stock_db")
#' # }
#'
#' # S4 generic definition
setGeneric(
  name = "open_stock_db",
  signature = c("stock_db"),
  def = open_stock_db <- function(stock_db, ...) {
    standardGeneric("open_stock_db")
  }
)


#' Close the stock database
#'
#' Generic function to close a stock database.
#'
#' @param stock_db A stock database object to operate.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return TRUE if succeed else FALSE.
#' @export
#'


# S3 generic definition
# close_stock_db <- function(stock_db, ...) {
#   UseMethod("close_stock_db")
# }

# S4 generic definition
setGeneric(
  name = "close_stock_db",
  signature = c("stock_db"),
  def = close_stock_db <- function(stock_db, ...) {
    standardGeneric("close_stock_db")
  }
)

#' Get profile of stock_db
#'
#' Generic function to get path of profile of stock_db.
#'
#' @param stock_db     A stock database object to operate.
#' @param profile_name  A character filename of profile.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return  full path of profile of stock db if succeed,
#' otherwise raise a error
#' @export
#'

# S3 generic definition
# get_profile <- function(stock_db, profile_name, ...){
#   UseMethod("get_profile")
# }
# S4 generic definition
setGeneric(
  name = "get_profile",
  signature = c("stock_db"),
  def = get_profile <- function(stock_db, profile_name, ...) {
    standardGeneric("get_profile")
  }
)

#' Init param of stock db
#'
#' Generic function to initiate params of a stock database.
#'
#' @param stock_db A stock database object to operate.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return TRUE if succeed else FALSE.
#'
#' @examples
#' \dontrun{
#' stock_db <- stock_db(gta_db, "GTA_SQLData")
#' open_stock_db(stock_db)
#' init_stock_db(stock_db)
#' }
#'
#' @export

# S3 generic definition
# init_stock_db <- function(stock_db, ...) {
#   UseMethod("init_stock_db")
# }

# S4 generic definition
setGeneric(
  name = "init_stock_db",
  signature = c("stock_db"),
  def = init_stock_db <- function(stock_db, ...) {
    standardGeneric("init_stock_db")
  }
)


#' List all tables of stock_db
#'
#' Generic function to list all tables of stock_db.
#'
#' @param stock_db  A stock database object to operate.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A vectors of characters of table names.
#'
#' @examples
#' \dontrun{
#' stock_db <- stock_db(gta_db, "GTA_SQLData")
#' open_stock_db(stock_db)
#' init_stock_db(stock_db)
#' list_stock_tables(stock_db)
#' }
#'
#' @export

# S3 generic definition
# list_stock_tables <- function(stock_db,...) {
#   UseMethod("list_stock_tables")
# }

# S4 generic definition
setGeneric(
  name = "list_stock_tables",
  signature = c("stock_db"),
  def = list_stock_tables <- function(stock_db, ...) {
    standardGeneric("list_stock_tables")
  }
)

#' Get dataset from a table in stock_db
#'
#' Generic function to get one dataset from stock_db.
#'
#' @param stock_db    A stock database object to operate.
#' @param table_name  Name of target table.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A data frame if succeed, otherwise NULL.
#'
#' @export
# S3 generic definition
# get_table_dataset <- function(stock_db, table_name,...) {
#   UseMethod("get_table_dataset")
# }
# S4 generic definition
setGeneric(
  name = "get_table_dataset",
  signature = c("stock_db"),
  def = get_table_dataset <- function(stock_db, table_name, ...) {
    standardGeneric("get_table_dataset")
  }
)

#' Get a dataset of a list of stock_cd from a table in stock_db
#'
#' Generic function to get a dataset of a list of stock_cd from table in stock.
#'
#' @param stock_db      A stock database object to operate.
#' @param table_name    Name of target table.
#' @param stock_cd_list A character vector of stock cd, default value of NULL means.
#'   all stock data will be returned.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A data frame on succeed otherwise NULL.
#'
#' @examples
#' \dontrun{
#' ds_trd_dalyr.df <- get_stock_dataset(stock_db,
#'   table_name = "TRD_Dalyr",
#'   stock_cd_list = c("600066", "000550")
#' )
#' }
#' @export

# S3 generic definition
# get_stock_dataset <- function(stock_db,
#                               table_name,
#                               stock_cd_list = NULL,
#                               ...) {
#   UseMethod("get_stock_dataset")
# }

# S4 generic definition
setGeneric(
  name = "get_stock_dataset",
  signature = c("stock_db"),
  def = get_stock_dataset <- function(stock_db,
                                      table_name,
                                      stock_cd_list = NULL,
                                      ...) {
    standardGeneric("get_stock_dataset")
  }
)

#' Get stock info from stock_db
#'
#' Generic function to get stock info from stock_db.
#'
#' @param stock_db    A stock database object to operate.
#' @param stock_cd_list A list of stock cd, default value of NULL means
#'  all stock data will return.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A dataframe of stock info.
#' @export
#'
# S3 generic definition
# get_stock_info <- function(stock_db,
#                              stock_cd_list = NULL,
#                              ...) {
#   UseMethod("get_stock_info")
# }

# S4 generic definition
setGeneric(
  name = "get_stock_info",
  signature = c("stock_db"),
  def = get_stock_info <- function(stock_db,
                                   stock_cd_list = NULL,
                                   ...) {
    standardGeneric("get_stock_info")
  }
)

#' Get industry info from stock_db
#'
#' Generic function to get industry info from stock_db.
#'
#' @param stock_db    A stock database object to operate.
#' @param industry_codes A list of industry codes, default value of NULL means
#'  all industry data will return.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A dataframe of stock info.
#' @export
#'
# S3 generic definition
# get_industry_info <- function(stock_db,
#                             industry_codes = NULL,
#                              ...) {
#   UseMethod("get_industry_info")
# }

# S4 generic definition
setGeneric(
  name = "get_industry_info",
  signature = c("stock_db"),
  def = get_industry_info <- function(stock_db,
                                      industry_codes = NULL,
                                      ...) {
    standardGeneric("get_industry_info")
  }
)

#' Get stock return timeseries from stock_db
#'
#' Generic function to get stock return timeseries from stock_db.
#'
#' @param stock_db    A stock database object to operate.
#' @param stock_cd_list A list of stock cd, default value of NULL means
#'   all stock data will return.
#' @param period_type Date period for time series, e.g. "day", "month",
#'   "year", by default "day".
#' @param period_date Choose start/end date of period as the date for
#'   observation
#' @param output_type Format of output result, e.g "timeSeries", "tibble".
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A timeseries of stock return.
#' @export
#'
# S3 generic definition
# get_stock_return <- function(stock_db,
#                              stock_cd_list = NULL,
#                              period_type = c("day", "month", "year"),
#                              period_date = c("start", "end"),
#                              output_type = c("timeSeries", "tibble"),
#                              ...) {
#   UseMethod("get_stock_return")
# }

# S4 generic definition
setGeneric(
  name = "get_stock_return",
  signature = c("stock_db"),
  def = get_stock_return <- function(stock_db,
                                     stock_cd_list = NULL,
                                     period_type = c("day", "month", "year"),
                                     period_date = c("start", "end"),
                                     output_type = c("timeSeries", "tibble"),
                                     ...) {
    standardGeneric("get_stock_return")
  }
)

#' Get market return timeseries from stock_db
#'
#' Generic function to get stock return timeseries from stock_db.
#'
#' @param stock_db    A stock database object to operate.
#' @param period_type Date period for time series, e.g. "day", "month",
#'   "year", by default value is  "day".
#' @param period_date Choose start/end date of period as the date for
#'   observation
#' @param output_type Format of output result, e.g "timeSeries", "tibble".
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A timeseries of market return.
#' @export
#'


# S3 generic definition
# get_market_return <- function(stock_db,
#                               period_type = c("day", "month", "year"),
#                               period_date = c("start", "end"),
#                               output_type = c("timeSeries", "tibble"),
#                               ...) {
#   UseMethod("get_market_return")
# }

# S4 generic definition
setGeneric(
  name = "get_market_return",
  signature = c("stock_db"),
  def = get_market_return <- function(stock_db,
                                      period_type = c("day", "month", "year"),
                                      period_date = c("start", "end"),
                                      output_type = c("timeSeries", "tibble"),
                                      ...) {
    standardGeneric("get_market_return")
  }
)

#' Get financial report timeseries from stock_db
#'
#' Generic function to get financial report timeseries from stock_db.
#'
#' @param stock_db    A stock database object to operate.
#'
#' @param stock_cd_list A character vector of stock cd, default value of NULL means.
#'   all stock data will be returned.
#'
#' @param statement   A string of statement type, i.e. "balance_sheet",
#' "income", "cashflow_direct","cashflow_indirect",
#' "income_ttm", "cashflow_direct_ttm", "cashflow_indirect_ttm".
#'
#' @param consolidated A logic indicate report is consolidated or not.
#'   Default TRUE means consolidated report, FALSE means parent company
#'   report.
#'
#' @param period_type Date period for time series, e.g. "quarter",
#'   "year", by default value is  "quarter".
#' @param period_date Choose start/end date of period as the date for
#'   observation
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A data frame of report timeseries if succeed, otherwise NULL.
#' @export
#'


# S3 generic definition
# get_financial_report <- function(stock_db,
#                               stock_cd_list = NULL,
#                               statement = c(
#                                 "balance_sheet",
#                                 "income",
#                                 "cashflow_direct",
#                                 "cashflow_indirect",
#                                 "income_ttm",
#                                 "cashflow_direct_ttm",
#                                 "cashflow_indirect_ttm"
#                               ),
#                               consolidated = TRUE,
#                               period_type = c("quarter", "year"),
#                               period_date = c("end","start"),
#                               ...) {
#   UseMethod("get_financial_report")
# }

# S4 generic definition
setGeneric(
  name = "get_financial_report",
  signature = c("stock_db"),
  def = get_financial_report <- function(stock_db,
                                         stock_cd_list = NULL,
                                         statement = c(
                                           "balance_sheet",
                                           "income",
                                           "cashflow_direct",
                                           "cashflow_indirect",
                                           "income_ttm",
                                           "cashflow_direct_ttm",
                                           "cashflow_indirect_ttm"
                                         ),
                                         consolidated = TRUE,
                                         period_type = c("quarter", "year"),
                                         period_date = c("end", "start"),
                                         ...) {
    standardGeneric("get_financial_report")
  }
)


#' Get indicators from specified source in stock_db
#'
#' Generic function to get indicator timeseries from specified source in stock_db.
#'
#' @param stock_db            A stock database object to operate.
#' @param indicator_source    A name of table or file(with extension)
#'   in which indicators are stored. For file, formats of rds,csv are supported.
#'
#' @param indicator_codes      A vector of indicator code. Default NULL return
#'   all indicators in the source.
#' @param ouput_format        Output format for data frame, i.e "long" and "wide":
#'   \itemize{
#'       \item in long format: code of indicator is stored in "ind_code",
#'       value of indicator is stored in "ind_value";
#'       \item in wide format: value of indicator is stored in
#'  field named with the name of indicator.
#'   }
#' @param ... Extra arguments to be passed to methods.
#'
#'
#' @family stock_db generics
#'
#' @return A data frame of indicator timeseries if succeed, otherwise NULL.
#' @export
#'

# S3 generic definition
# get_indicators_from_source <- function(stock_db, indicator_source,
#                                          indicator_codes = NULL,
#                                          ouput_format = c("long", "wide"),
#                                          ...)
#   UseMethod("get_indicators_from_source")
# }
# S4 generic definition
setGeneric(
  name = "get_indicators_from_source",
  signature = c("stock_db"),
  def = get_indicators_from_source <- function(stock_db, indicator_source,
                                               indicator_codes = NULL,
                                               ouput_format = c("long", "wide"),
                                               ...) {
    standardGeneric("get_indicators_from_source")
  }
)

#' Save indicators to specified source in stock_db
#'
#' Generic function to save indicator timeseries to specified source in stock_db.
#'
#' @param stock_db            A stock database object to operate.
#' @param indicator_source    A name of table or file(with extension)
#'   in which indicators are stored. For file, formats of rds,csv are supported.
#' @param ts_indicators       A dataframe of indicator timeseries
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return NULL invisibly. Raise error if anything goes wrong.
#' @export
#'

# S3 generic definition
# save_indicators_to_source <- function(stock_db, indicator_source,
#                                       ts_indicators, ...)
#   UseMethod("save_indicators_to_source")
# }
# S4 generic definition
setGeneric(
  name = "save_indicators_to_source",
  signature = c("stock_db"),
  def = save_indicators_to_source <- function(stock_db, indicator_source,
                                              ts_indicators, ...) {
    standardGeneric("save_indicators_to_source")
  }
)



#' Get indicators from stock_db
#'
#' Generic function to get indicator timeseries from stock_db.
#'
#' @param stock_db            A stock database object to operate.
#' @param indicator_codes     A vector of indicator code.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A dataframe of indicator timeseries if succeed, otherwise NULL.
#'   In order to store multi-indicators with different periods(day,
#'   month, quarter, year), returned data frame adapts longer format,
#'   which means code of indicator is stored in "ind_code", value of factor
#'   is stored in "ind_value".
#' @export
#'

# S3 generic definition
# get_indicators <- function(stock_db, indicator_codes, ...){
#   UseMethod("get_indicators")
# }
# S4 generic definition
setGeneric(
  name = "get_indicators",
  signature = c("stock_db"),
  def = get_indicators <- function(stock_db, indicator_codes, ...) {
    standardGeneric("get_indicators")
  }
)

#' Get indicators Info from stock_db
#'
#' Generic function to get indicator info from stock_db.
#'
#' @param stock_db         A stock database object to operate.
#' @param indicator_codes     A character vector of indicator groups.
#' Default NULL return all indicators.
##' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A dataframe of matched indicators if succeed, otherwise NULL.
#' @export
#'

# S3 generic definition
# get_indicators_info <- function(stock_db, indicator_codes = NULL,
#                              ...){
#   UseMethod("get_indicators_info")
# }
# S4 generic definition
setGeneric(
  name = "get_indicators_info",
  signature = c("stock_db"),
  def = get_indicators_info <- function(stock_db, indicator_codes = NULL,
                                        ...) {
    standardGeneric("get_indicators_info")
  }
)


#' Get factors from stock_db
#'
#' Generic function to get factor timeseries from stock_db.
#'
#' @param stock_db         A stock database object to operate.
#' @param factor_codes    A vector of factor code.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A dataframe of factor timeseries if succeed, otherwise NULL.
#'   In order to store multi-factors with different periods(day,
#'   month, quarter, year), returned data frame adapts longer format,
#'   which means name of factor is stored in "factor_name", value of factor
#'   is stored in "factor_value".
#' @export
#'

# S3 generic definition
# get_factors <- function(stock_db, factor_codes, ...){
#   UseMethod("get_factors")
# }
# S4 generic definition
setGeneric(
  name = "get_factors",
  signature = c("stock_db"),
  def = get_factors <- function(stock_db, factor_codes, ...) {
    standardGeneric("get_factors")
  }
)


#' Get factors Info from stock_db
#'
#' Generic function to get factors info from stock_db.
#'
#' @param stock_db         A stock database object to operate.
#' @param factor_codes     A character vector of factor groups. Default NULL return
#'   all factors.
#' @param factor_groups    A character vector of factor groups. Default NULL return
#'   all factors.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A dataframe of matched factors if succeed, otherwise NULL.
#' @export
#'

# S3 generic definition
# get_factors_info <- function(stock_db, factor_codes = NULL,
#                              factor_group = NULL,...){
#   UseMethod("get_factors_info")
# }
# S4 generic definition
setGeneric(
  name = "get_factors_info",
  signature = c("stock_db"),
  def = get_factors_info <- function(stock_db, factor_codes = NULL,
                                     factor_groups = NULL, ...) {
    standardGeneric("get_factors_info")
  }
)

#' Get industry info of stocks from stock_db
#'
#' Generic function to get industry info timeseries from stock_db.
#'
#' @param stock_db     A stock database object to operate.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A dataframe of industry timeseries of stocks if succeed,
#'   otherwise NULL.
#' @export
#'

# S3 generic definition
# get_stock_industry <- function(stock_db, ...){
#   UseMethod("get_stock_industry")
# }
# S4 generic definition
setGeneric(
  name = "get_stock_industry",
  signature = c("stock_db"),
  def = get_stock_industry <- function(stock_db, ...) {
    standardGeneric("get_stock_industry")
  }
)

#' Get stock info of special treatment from stock_db
#'
#' Generic function to stock info of special treatment from stock_db.
#'
#' @param stock_db     A stock database object to operate.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A dataframe stock info of special treatment if succeed, otherwise NULL.
#' @export
#'

# S3 generic definition
# get_spt_stocks <- function(stock_db, ...){
#   UseMethod("get_spt_stocks")
# }
# S4 generic definition
setGeneric(
  name = "get_spt_stocks",
  signature = c("stock_db"),
  def = get_spt_stocks <- function(stock_db, ...) {
    standardGeneric("get_spt_stocks")
  }
)


#' Get riskfree rate from stock_db
#'
#' Generic function to get riskfree rate timeseries from stock_db.
#'
#' @param stock_db     A stock database object to operate.
#' @param period       Date period of time series, e.g. "day", "month",
#'   "quarter", "year", default is "day".
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A dataframe of riskfree rate timeseries if succeed, otherwise NULL.
#' @export
#'

# S3 generic definition
# get_riskfree_rate <- function(stock_db, period = c("day", "month",
#                                                 "quarter", "year"), ...){
#   UseMethod("get_riskfree_rate")
# }
# S4 generic definition
setGeneric(
  name = "get_riskfree_rate",
  signature = c("stock_db"),
  def = get_riskfree_rate <- function(stock_db,
                                      period = c(
                                        "day", "month",
                                        "quarter", "year"
                                      ), ...) {
    standardGeneric("get_riskfree_rate")
  }
)


#' Get Path of Data Directory from stock_db
#'
#' Generic function to get path of data directory from stock_db.
#'
#'
#' @param stock_db         A stock database object to operate.
#' @param dir_id           A character id of directory.
#' \itemize{
#'       \item DIR_DB_DATA: dir of database of stock_db;
#'       \item DIR_DB_DATA_SOURCE : dir of source data to process into database;
#'       \item DIR_DB_DATA_ORIGIN:  dir of origin data to import into database;
#'       \item DIR_DB_DATA_LOG: dir of log of database operation;
#'       \item DIR_DB_DATA_INDICATOR: dir of customized indicators.
#'       }
#'
#' @param force            Whether return result if dir doesn't existed.
#'   Default TRUE, return result if dir doesn't exist.
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return A full path of dir if succeed, otherwise NULL.
#'  If the path of dir doesn't exist and force = FALSE, it will raise a error.
#' @export
#'

# S3 generic definition
# dir_path_db <- function(stock_db,
#                      dir_id = c("DIR_DB_DATA",
#                                 "DIR_DB_DATA_SOURCE",
#                                 "DIR_DB_DATA_ORIGIN",
#                                 "DIR_DB_DATA_LOG",
#                                 "DIR_DB_DATA_INDICATOR"),
#                      force = TRUE,...)
#   UseMethod("dir_path_db")
# }
# S4 generic definition
setGeneric(
  name = "dir_path_db",
  signature = c("stock_db"),
  def = dir_path_db <- function(stock_db,
                                dir_id = c(
                                  "DIR_DB_DATA",
                                  "DIR_DB_DATA_SOURCE",
                                  "DIR_DB_DATA_ORIGIN",
                                  "DIR_DB_DATA_LOG",
                                  "DIR_DB_DATA_INDICATOR"
                                ),
                                force = TRUE, ...) {
    standardGeneric("dir_path_db")
  }
)


# Non-generic functions for stock db operation ---------------------------------

#' Get assets return from market and stocks return
#'
#' Get assets return timeseries by combining market return and stocks return
#'
#' @param benchmark_return   A timeseries of market index
#' @param stocks_return      A timeseries of a group stock stocks
#'
#'
#' @return A timeseries of assets return.
#' @export
get_assets_return <- function(benchmark_return, stocks_return) {
  stopifnot(
    timeSeries::is.timeSeries(benchmark_return),
    timeSeries::is.timeSeries(stocks_return)
  )


  start_date_market <- timeSeries::start(benchmark_return)
  end_date_market <- timeSeries::end(benchmark_return)

  start_date_stocks <- timeSeries::start(stocks_return)
  end_date_stocks <- timeSeries::end(stocks_return)

  # Used later start_date as start_date
  if (start_date_market >= start_date_stocks) {
    start_date <- start_date_market
  } else {
    start_date <- start_date_stocks
  }

  # Used early end_date as end_date
  if (end_date_market <= end_date_stocks) {
    end_date <- end_date_market
  } else {
    end_date <- end_date_stocks
  }

  # get data window between start_date and end_date
  benchmark_return <- timeSeries::window(benchmark_return, start_date, end_date)
  stocks_return <- timeSeries::window(stocks_return, start_date, end_date)

  # Combine benchmark and stocks return
  assets_return <- merge(benchmark_return, stocks_return)
  colnames(assets_return) <- stringr::str_replace(colnames(assets_return), "X", "")

  return(assets_return)
}

#' Get stocks excess return from stocks return and riskfree_rate
#'
#' Get excess return timeseries by combining stocks return and riskfree_rate
#'
#' @param ts_stocks_return   A timeseries of stocks_return
#' @param ts_riskfree_rate   A timeseries of riskfree_rate
#' @param period             A character of period, e.g. "day", "month",
#'   "quarter", "year". Default "day".
#' @param period_date        A character of period_date format, e.g. "start",
#'   "end", "start" format date as start of the period, "end" format date as end
#'   of period. Default "start".
#'
#'
#' @return A timeseries of excess return of stocks.
#' @export

stocks_excess_return <- function(ts_stocks_return,
                                 ts_riskfree_rate,
                                 period = c(
                                   "day", "month",
                                   "quarter", "year"
                                 ),
                                 period_date = c("start", "end")) {
  ts_stock_return_expr <- rlang::enexpr(ts_stocks_return)
  ts_riskfree_rate_expr <- rlang::enexpr(ts_riskfree_rate)

  # validate params
  assertive::assert_is_data.frame(ts_stocks_return)
  assertive::assert_is_data.frame(ts_riskfree_rate)

  # set date of timeseries
  period <- match.arg(period)
  period_date <- match.arg(period_date)
  if (is_periodic_dates(ts_stocks_return$date, freq_rule = period)) {
    ts_stocks_return$date <- as_period_date(ts_stocks_return$date,
      period = period,
      period_date = period_date
    )
  } else {
    msg <- sprintf(
      "The period of date of %s isn't %s",
      rlang::expr_text(ts_stock_return_expr),
      period
    )
    rlang::abort(msg)
  }

  if (is_periodic_dates(ts_riskfree_rate$date, freq_rule = period)) {
    ts_riskfree_rate$date <- as_period_date(ts_riskfree_rate$date,
      period = period,
      period_date = period_date
    )
  } else {
    msg <- sprintf(
      "The period of date of %s isn't %s",
      rlang::expr_text(ts_riskfree_rate_expr),
      period
    )
    rlang::abort(msg)
  }

  # connect riskfree rate with stkcds
  stkcds <- unique(ts_stocks_return$stkcd)
  ds_stkcds <- tibble::tibble(stkcd = stkcds)
  ts_riskfree_rate_with_stkcd <- ds_stkcds %>%
    dplyr::mutate(data = list(ts_riskfree_rate)) %>%
    tidyr::unnest(data)

  # combine stocks_return and riskfree_rate to compute excess return
  ts_stocks_excess_return <- ts_stocks_return %>%
    dplyr::inner_join(ts_riskfree_rate_with_stkcd, by = c("date", "stkcd")) %>%
    dplyr::mutate(excess_return = .data$return - .data$riskfree_return)

  return(ts_stocks_excess_return)
}

# Get a timeseries of stock data for specified stock from table datasets
get_stock_field_dataset <- function(ds_source.df,
                                    stock_cd,
                                    target_field,
                                    stkcd_field = "stkcd",
                                    date_field = "trdmnt",
                                    tseries_type = c("timeSeries", "xts")) {

  # Validate params
  if (is.null(ds_source.df) || missing(stock_cd)
  || missing(target_field) || missing(date_field)) {
    rlang::abort("ds_source.df, stock_cd, target_field, date_field  mustn't be null")
  }

  # Check whether the data fields existed
  field_list <- c(stkcd_field, target_field, date_field)
  if (!all(field_list %in% names(ds_source.df))) {
    error_fields <- NULL
    for (field_name in field_list) {
      if (!field_name %in% names(ds_source.df)) {
        error_fields <- ifelse(is.null(error_fields),
          field_name,
          paste(error_fields, field_name, sep = ",")
        )
      }
    }

    error_msg <- sprintf("%s doesn't exist in dataset ", error_fields)
    rlang::abort(error_msg)
  }

  tseries_type <- match.arg(tseries_type)
  if (is.null(tseries_type)) {
    rlang::warn("teries_type should be timeSeries or xts, set as timeSeries by default")
    tseries_type <- "timeSeries"
  }

  # Coerce stock code to 6 digit of characters
  if (!is.character(stock_cd)) {
    stock_cd <- stringr::str_pad(stock_cd, width = 6, pad = "0")
    msg <- "Coerce stock cd to character of 6 digits if it were number"
    warnings(msg)
  }

  # Get related data of the specified stock from all stock trd_mnth data table
  ds_stock_data.df <- na.omit(ds_source.df[ds_source.df$stkcd == stock_cd, ])


  # Build result dataset for specified stock
  result_ts <- NULL
  if (tseries_type == "timeSeries") {
    # timeSeries data series
    ds_name <- sprintf("ds_%s_%s.fts", stock_cd, target_field)
    result_ts <- timeSeries::timeSeries(
      ds_stock_data.df[target_field],
      zoo::as.Date(zoo::as.yearmon(
        ds_stock_data.df[[date_field]]
      ))
    )
    colnames(result_ts) <- stock_cd
  } else {
    # xts data series
    ds_name <- sprintf("ds_%s_%s.xts", stock_cd, target_field)
    result_ts <- xts::xts(ds_stock_data.df[target_field],
      order.by = zoo::as.Date(
        zoo::as.yearmon(ds_stock_data.df[[date_field]])
      )
    )
    colnames(result_ts) <- stock_cd
  }

  # Sort result
  result_ts <- sort(result_ts)

  # Return the result timeseries of stock

  return(result_ts)
}

# Get several timeseries of stocks data for multiple stocks from periodic dataset
fetch_stock_field_dataset <- function(ds_source.df,
                                      stock_cd_list,
                                      replaceNA = c("keep", "zeros", "mean", "median"),
                                      ...) {


  # Validate params
  if (is.null(ds_source.df) || missing(stock_cd_list)) {
    rlang::abort("ds_source.df, stock_cd_list mustn't be null")
  }

  stopifnot(length(stock_cd_list) != 0, length(ds_source.df) != 0)

  # Coerce stock code to 6 digit of characters
  if (!is.character(stock_cd_list)) {
    stock_cd_list <- stringr::str_pad(stock_cd_list, width = 6, pad = "0")
    msg <- "Coerce stock cd to character of 6 digits if it were number"
    warnings(msg)
  }

  ds_result <- NULL
  for (the_stock_cd in stock_cd_list) {

    # get stock data for specified stock
    ds_stock_data <- get_stock_field_dataset(
      ds_source.df = ds_source.df,
      stock_cd = the_stock_cd, ...
    )

    # Build the result dataset
    if (is.null(ds_result)) {
      # Set stock data as result dataset
      ds_result <- ds_stock_data
    } else {
      # Merge stock data into the result dataset
      ds_result <- merge(ds_result, ds_stock_data)
    }
  }

  # remove the na as request
  na_type <- match.arg(replaceNA)
  if (na_type != "keep") {
    ds_nona_result <- timeSeries::substituteNA(ds_result, type = na_type)
    if (xts::is.xts(ds_result)) {
      ds_result <- xts::as.xts(ds_nona_result)
    }
    else {
      ds_result <- ds_nona_result
    }
  }

  return(ds_result)
}

# Generic functions for tranlation between code and name -----------------------

#' Translate code into name
#'
#' Generic function to translate code into name
#'
#' @param x    A object containing code/name information.
#' @param code A code or a vector of codes to be translated.
#'  if exact_match is FALSE, code could be regular expression for
#'  non-exact matching.
#' @param exact_match  A logic to determine use exact matching or not.
#'  Default TRUE means to use exact matching
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return     A name or a vector of names.
#' @export
#'


# S3 generic definition
# code2name <- function(x, code, exact_match = TRUE, ...) {
#   UseMethod("code2name")
# }

# S4 generic definition
setGeneric(
  name = "code2name",
  signature = c("x"),
  def = code2name <- function(x, code, exact_match = TRUE, ...) {
    standardGeneric("code2name")
  }
)


#' Translate name into code
#'
#' Generic function to translate name into code
#'
#' @param x     A object containing code/name information.
#' @param name  A name or a vector of names to be translated.
#'  if exact_match is FALSE, name could be regular expression for
#'  non-exact matching.
#' @param exact_match  A logic to determine use exact matching or not.
#'  Default TRUE means to use exact matching
#' @param ... Extra arguments to be passed to methods.
#'
#' @family stock_db generics
#'
#' @return      A code or a vector of codes.
#' @export
#'


# S3 generic definition
# name2code <- function(x, name, exact_match = TRUE, ...) {
#   UseMethod("name2code")
# }

# S4 generic definition
setGeneric(
  name = "name2code",
  signature = c("x"),
  def = name2code <- function(x, name, exact_match = TRUE, ...) {
    standardGeneric("name2code")
  }
)
chriszheng2016/zstmodelr documentation built on June 13, 2021, 8:59 p.m.