Nothing
R/hspec.R
In emhawkes: Exponential Multivariate Hawkes Model
setClassUnion("matrixORnumeric", c("matrix", "numeric"))
setClassUnion("functionORNULL",members=c("function", "NULL"))
setClassUnion("listORNULL",members=c("list", "NULL"))
setClassUnion("matrixORnumericORfunction", c("matrix", "numeric", "function"))
setClassUnion("matrixORnumericORfunctionORNULL", c("matrix", "numeric", "function", "NULL"))
#' An S4 class to represent an exponential marked Hawkes model
#'
#' This class represents a specification of a marked Hawkes model with exponential kernel.
#' The intensity of the ground process is defined by:
#' \deqn{\lambda(t) = \mu + \int_{(-\infty,t)\times E} ( \alpha + g(u, z) ) e^{-\beta (t-u)} M(du \times dz).}
#' For more details, please see the vignettes.
#'
#' \eqn{\mu} is base intensity.
#' This is generally a constant vector but can be extended to stochastic processes.
#' Currently, piecewise constant mu is also possible. mu is left continuous.
#'
#' \eqn{\alpha} is a constant matrix which represents impacts on intensities after events.
#' It is represented by slot \code{alpha}.
#'
#' \eqn{g} is for non-constant parts of the impact.
#' It may depend on any information generated by \eqn{N}, \eqn{\lambda}, \eqn{z} and so on.
#' It is represented by slot \code{impact}.
#'
#' \eqn{\beta} is a constant matrix for exponential decay rates.
#' It is represented by slot \code{beta}.
#'
#' \eqn{z} is mark and represented by slot \code{rmark}.
#'
#' \code{mu}, \code{alpha} and \code{beta} are required slots for every exponential Hawkes model.
#' \code{rmark} and \code{impact} are additional slots.
#'
#' @slot mu Numeric value or matrix or function, if numeric, automatically converted to matrix.
#' @slot alpha Numeric value or matrix or function, if numeric, automatically converted to matrix, exciting term.
#' @slot beta Numeric value or matrix or function, if numeric, automatically converted to matrix, exponential decay.
#' @slot eta Numeric value or matrix or function, if numeric, automatically converted to matrix, impact by additional mark.
#' @slot dimens Dimension of the model.
#' @slot rmark A function that generates mark for counting process, for simulation.
#' @slot dmark A density function for mark, for estimation.
#' @slot impact A function that describe the after impact of mark to lambda whose first argument is always `param`.
#' @slot type_col_map Mapping between type and column number of kernel used for multi-kernel model.
#'
#' @examples
#' MU <- matrix(c(0.2), nrow = 2)
#' ALPHA <- matrix(c(0.75, 0.92, 0.92, 0.75), nrow = 2, byrow=TRUE)
#' BETA <- matrix(c(2.25, 2.25, 2.25, 2.25), nrow = 2, byrow=TRUE)
#' mhspec2 <- new("hspec", mu=MU, alpha=ALPHA, beta=BETA)
#' mhspec2
#'
#' @export
setClass("hspec",
slots = list(
mu = "matrixORnumericORfunction",
alpha = "matrixORnumericORfunction",
beta = "matrixORnumericORfunction",
eta = "matrixORnumericORfunctionORNULL",
dimens = "numeric",
rmark = "functionORNULL",
dmark = "functionORNULL",
impact = "functionORNULL",
type_col_map = "listORNULL"
)
)
# Initialize the hspec object
#
#
# \code{mu}, \code{alpha} and \code{beta} are required slots for every exponential Hawkes model.
# \code{mark} and \code{impact} are additional slots.
#
# @param .Object \code{hspec}
# @param mu Numeric value or matrix or function, if numeric, automatically converted to matrix.
# @param alpha numeric value or matrix or function, if numeric, automatically converted to matrix, exciting term
# @param beta numeric value or matrix or function, if numeric,, automatically converted to matrix, exponential decay
# @param dimens dimesion of the model
# @param rmark a function that generate mark
# @param impact a function that describe the mark impact whose first argument is always `param`
# @param stability_check check the spectral radius
setMethod(
"initialize",
"hspec",
function(.Object, mu, alpha, beta, eta=NULL, impact=NULL, type_col_map = NULL, dimens=NULL,
rmark=NULL, dmark = NULL, stability_check = FALSE){
# If rmark is not provided, then rmark is constant 1.
# if (is.null(rmark)) rmark <- function(...) 1
# check the number of arguments
# if(length(formals(rmark)) == 0){
# .Object@rmark <- function(...) rmark()
#} else {
# .Object@rmark <- rmark
#}
.Object@rmark <- rmark
if( !is.function(mu) & !is.matrix(mu) ){
.Object@mu <- as.matrix(mu)
} else{
.Object@mu <- mu
}
if( !is.function(alpha) & !is.matrix(alpha) ){
.Object@alpha <- as.matrix(alpha)
} else{
.Object@alpha <- alpha
}
if( !is.function(beta) & !is.matrix(beta) ){
.Object@beta <- as.matrix(beta)
} else {
.Object@beta <- beta
}
if( !is.null(eta) & !is.function(eta) & !is.matrix(eta) ){
.Object@eta <- as.matrix(eta)
} else {
.Object@eta <- eta
}
.Object@type_col_map <- type_col_map
.Object@dmark <- dmark
.Object@impact <- impact
nrow_mu <- ncol_mu <- NULL
if( is.matrix(.Object@mu) ) {
nrow_mu <- nrow(.Object@mu)
ncol_mu <- ncol(.Object@mu)
if (ncol_mu != 1) stop("The number of column in mu should be one.")
} else if( is.function(.Object@mu) && length(formals(.Object@mu)) == 1 && names(formals(.Object@mu)[1]) == "param"){
nrow_mu <- nrow(evalf(.Object@mu))
ncol_mu <- ncol(evalf(.Object@mu))
if (ncol_mu != 1) stop("The number of column in mu should be one.")
}
nrow_alpha <- ncol_alpha <- nrow_beta <- ncol_beta <- nrow_eta <- ncol_eta <- NULL
if ( is.matrix(.Object@alpha) ) {
nrow_alpha <- nrow(.Object@alpha)
ncol_alpha <- ncol(.Object@alpha)
} else if( is.function(.Object@alpha) && length(formals(.Object@alpha)) == 1 && names(formals(.Object@alpha)[1]) == "param"){
nrow_alpha <- nrow(evalf(.Object@alpha))
ncol_alpha <- ncol(evalf(.Object@alpha))
}
if ( is.matrix(.Object@beta) ) {
nrow_beta <- nrow(.Object@beta)
ncol_beta <- ncol(.Object@beta)
} else if( is.function(.Object@beta) && length(formals(.Object@beta)) == 1 && names(formals(.Object@beta)[1]) == "param"){
nrow_beta <- nrow(evalf(.Object@beta))
ncol_beta <- ncol(evalf(.Object@beta))
}
if (!is.null(.Object@eta)){
if(is.matrix(.Object@eta)){
nrow_eta <- nrow(.Object@eta)
ncol_eta <- ncol(.Object@eta)
} else if (is.function(.Object@eta) &&length(formals(.Object@eta)) == 1 && names(formals(.Object@eta)[1]) == "param"){
nrow_eta <- nrow(evalf(.Object@eta))
ncol_eta <- ncol(evalf(.Object@eta))
}
}
if(is.null(dimens) & is.null(nrow_mu) & is.null(nrow_alpha) & is.null(nrow_beta) & is.null(nrow_eta)) {
stop("dimens should be provided in this model.")
}
if (length(unique(c(dimens, nrow_mu, nrow_alpha, nrow_beta, nrow_eta)))==1) {
.Object@dimens <- unique(c(dimens, nrow_mu, nrow_alpha, nrow_beta, nrow_eta))
} else {
stop("The number of rows in parameters and given dimens are all should be the same.")
}
if (length(unique(c(ncol_alpha, ncol_beta, ncol_eta))) != 1) {
stop("The number of columns in alpha, beta, eta are all should be the same.")
}
if (ncol_alpha > .Object@dimens & is.null(.Object@type_col_map)) {
stop("type_col_map should be provided for this model as the number of columns in parameters exceed the dimens")
}
# set dimens
# if( is.null(dimens)){
# if( is.matrix(.Object@mu) ){
# .Object@dimens <- length(.Object@mu)
# } else if ( is.matrix(.Object@alpha) ) {
# .Object@dimens <- nrow(.Object@alpha)
# } else if ( is.matrix(.Object@beta) ) {
# .Object@dimens <- nrow(.Object@beta)
# } else if ( is.function(.Object@mu) ){
# .Object@dimens <- nrow(evalf(.Object@mu))
# } else if ( is.function(.Object@alpha) ){
# .Object@dimens <- nrow(evalf(.Object@alpha))
# } else if (is.function(.Object@beta) ){
# .Object@dimens <- nrow(evalf(.Object@beta))
# } else {
# stop("argument \"dimens\" is missing, with no default")
# }
# }
#
# Check spectral radius, only works for non marked model
if ( stability_check==TRUE && max(abs(eigen(alpha/beta)$values)) > 1)
warning("This model may not satisfy the stability condition.")
methods::callNextMethod()
.Object
}
)
setMethod("show", "hspec", function(object) {
cat("An object of class \"hsepc\" of ", object@dimens, "-dimensional Hawkes process", "\n\n", sep='')
if(!is.null(object@mu)){
cat("Slot mu: \n")
print(object@mu)
cat("\n")
}
if(!is.null(object@alpha)){
cat("Slot alpha: \n")
print(object@alpha)
cat("\n")
}
if(!is.null(object@beta)){
cat("Slot beta: \n")
print(object@beta)
cat("\n")
}
if(!is.null(object@eta)){
cat("Slot eta: \n")
print(object@eta)
cat("\n")
}
if(!is.null(object@impact)){
cat("Slot impact: \n")
print(object@impact)
cat("\n")
}
if(!is.null(object@type_col_map)){
cat("Slot type_col_map: \n")
print(object@type_col_map)
cat("\n")
}
if(!is.null(object@rmark)){
cat("Slot rmark: \n")
print(object@rmark)
cat("\n")
}
if(!is.null(object@dmark)){
cat("Slot dmark: \n")
print(object@dmark)
cat("\n")
}
})
Try the emhawkes package in your browser
Any scripts or data that you put into this service are public.
emhawkes documentation built on Feb. 16, 2023, 9: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.
setClassUnion("matrixORnumeric", c("matrix", "numeric"))
setClassUnion("functionORNULL",members=c("function", "NULL"))
setClassUnion("listORNULL",members=c("list", "NULL"))
setClassUnion("matrixORnumericORfunction", c("matrix", "numeric", "function"))
setClassUnion("matrixORnumericORfunctionORNULL", c("matrix", "numeric", "function", "NULL"))
#' An S4 class to represent an exponential marked Hawkes model
#'
#' This class represents a specification of a marked Hawkes model with exponential kernel.
#' The intensity of the ground process is defined by:
#' \deqn{\lambda(t) = \mu + \int_{(-\infty,t)\times E} ( \alpha + g(u, z) ) e^{-\beta (t-u)} M(du \times dz).}
#' For more details, please see the vignettes.
#'
#' \eqn{\mu} is base intensity.
#' This is generally a constant vector but can be extended to stochastic processes.
#' Currently, piecewise constant mu is also possible. mu is left continuous.
#'
#' \eqn{\alpha} is a constant matrix which represents impacts on intensities after events.
#' It is represented by slot \code{alpha}.
#'
#' \eqn{g} is for non-constant parts of the impact.
#' It may depend on any information generated by \eqn{N}, \eqn{\lambda}, \eqn{z} and so on.
#' It is represented by slot \code{impact}.
#'
#' \eqn{\beta} is a constant matrix for exponential decay rates.
#' It is represented by slot \code{beta}.
#'
#' \eqn{z} is mark and represented by slot \code{rmark}.
#'
#' \code{mu}, \code{alpha} and \code{beta} are required slots for every exponential Hawkes model.
#' \code{rmark} and \code{impact} are additional slots.
#'
#' @slot mu Numeric value or matrix or function, if numeric, automatically converted to matrix.
#' @slot alpha Numeric value or matrix or function, if numeric, automatically converted to matrix, exciting term.
#' @slot beta Numeric value or matrix or function, if numeric, automatically converted to matrix, exponential decay.
#' @slot eta Numeric value or matrix or function, if numeric, automatically converted to matrix, impact by additional mark.
#' @slot dimens Dimension of the model.
#' @slot rmark A function that generates mark for counting process, for simulation.
#' @slot dmark A density function for mark, for estimation.
#' @slot impact A function that describe the after impact of mark to lambda whose first argument is always `param`.
#' @slot type_col_map Mapping between type and column number of kernel used for multi-kernel model.
#'
#' @examples
#' MU <- matrix(c(0.2), nrow = 2)
#' ALPHA <- matrix(c(0.75, 0.92, 0.92, 0.75), nrow = 2, byrow=TRUE)
#' BETA <- matrix(c(2.25, 2.25, 2.25, 2.25), nrow = 2, byrow=TRUE)
#' mhspec2 <- new("hspec", mu=MU, alpha=ALPHA, beta=BETA)
#' mhspec2
#'
#' @export
setClass("hspec",
slots = list(
mu = "matrixORnumericORfunction",
alpha = "matrixORnumericORfunction",
beta = "matrixORnumericORfunction",
eta = "matrixORnumericORfunctionORNULL",
dimens = "numeric",
rmark = "functionORNULL",
dmark = "functionORNULL",
impact = "functionORNULL",
type_col_map = "listORNULL"
)
)
# Initialize the hspec object
#
#
# \code{mu}, \code{alpha} and \code{beta} are required slots for every exponential Hawkes model.
# \code{mark} and \code{impact} are additional slots.
#
# @param .Object \code{hspec}
# @param mu Numeric value or matrix or function, if numeric, automatically converted to matrix.
# @param alpha numeric value or matrix or function, if numeric, automatically converted to matrix, exciting term
# @param beta numeric value or matrix or function, if numeric,, automatically converted to matrix, exponential decay
# @param dimens dimesion of the model
# @param rmark a function that generate mark
# @param impact a function that describe the mark impact whose first argument is always `param`
# @param stability_check check the spectral radius
setMethod(
"initialize",
"hspec",
function(.Object, mu, alpha, beta, eta=NULL, impact=NULL, type_col_map = NULL, dimens=NULL,
rmark=NULL, dmark = NULL, stability_check = FALSE){
# If rmark is not provided, then rmark is constant 1.
# if (is.null(rmark)) rmark <- function(...) 1
# check the number of arguments
# if(length(formals(rmark)) == 0){
# .Object@rmark <- function(...) rmark()
#} else {
# .Object@rmark <- rmark
#}
.Object@rmark <- rmark
if( !is.function(mu) & !is.matrix(mu) ){
.Object@mu <- as.matrix(mu)
} else{
.Object@mu <- mu
}
if( !is.function(alpha) & !is.matrix(alpha) ){
.Object@alpha <- as.matrix(alpha)
} else{
.Object@alpha <- alpha
}
if( !is.function(beta) & !is.matrix(beta) ){
.Object@beta <- as.matrix(beta)
} else {
.Object@beta <- beta
}
if( !is.null(eta) & !is.function(eta) & !is.matrix(eta) ){
.Object@eta <- as.matrix(eta)
} else {
.Object@eta <- eta
}
.Object@type_col_map <- type_col_map
.Object@dmark <- dmark
.Object@impact <- impact
nrow_mu <- ncol_mu <- NULL
if( is.matrix(.Object@mu) ) {
nrow_mu <- nrow(.Object@mu)
ncol_mu <- ncol(.Object@mu)
if (ncol_mu != 1) stop("The number of column in mu should be one.")
} else if( is.function(.Object@mu) && length(formals(.Object@mu)) == 1 && names(formals(.Object@mu)[1]) == "param"){
nrow_mu <- nrow(evalf(.Object@mu))
ncol_mu <- ncol(evalf(.Object@mu))
if (ncol_mu != 1) stop("The number of column in mu should be one.")
}
nrow_alpha <- ncol_alpha <- nrow_beta <- ncol_beta <- nrow_eta <- ncol_eta <- NULL
if ( is.matrix(.Object@alpha) ) {
nrow_alpha <- nrow(.Object@alpha)
ncol_alpha <- ncol(.Object@alpha)
} else if( is.function(.Object@alpha) && length(formals(.Object@alpha)) == 1 && names(formals(.Object@alpha)[1]) == "param"){
nrow_alpha <- nrow(evalf(.Object@alpha))
ncol_alpha <- ncol(evalf(.Object@alpha))
}
if ( is.matrix(.Object@beta) ) {
nrow_beta <- nrow(.Object@beta)
ncol_beta <- ncol(.Object@beta)
} else if( is.function(.Object@beta) && length(formals(.Object@beta)) == 1 && names(formals(.Object@beta)[1]) == "param"){
nrow_beta <- nrow(evalf(.Object@beta))
ncol_beta <- ncol(evalf(.Object@beta))
}
if (!is.null(.Object@eta)){
if(is.matrix(.Object@eta)){
nrow_eta <- nrow(.Object@eta)
ncol_eta <- ncol(.Object@eta)
} else if (is.function(.Object@eta) &&length(formals(.Object@eta)) == 1 && names(formals(.Object@eta)[1]) == "param"){
nrow_eta <- nrow(evalf(.Object@eta))
ncol_eta <- ncol(evalf(.Object@eta))
}
}
if(is.null(dimens) & is.null(nrow_mu) & is.null(nrow_alpha) & is.null(nrow_beta) & is.null(nrow_eta)) {
stop("dimens should be provided in this model.")
}
if (length(unique(c(dimens, nrow_mu, nrow_alpha, nrow_beta, nrow_eta)))==1) {
.Object@dimens <- unique(c(dimens, nrow_mu, nrow_alpha, nrow_beta, nrow_eta))
} else {
stop("The number of rows in parameters and given dimens are all should be the same.")
}
if (length(unique(c(ncol_alpha, ncol_beta, ncol_eta))) != 1) {
stop("The number of columns in alpha, beta, eta are all should be the same.")
}
if (ncol_alpha > .Object@dimens & is.null(.Object@type_col_map)) {
stop("type_col_map should be provided for this model as the number of columns in parameters exceed the dimens")
}
# set dimens
# if( is.null(dimens)){
# if( is.matrix(.Object@mu) ){
# .Object@dimens <- length(.Object@mu)
# } else if ( is.matrix(.Object@alpha) ) {
# .Object@dimens <- nrow(.Object@alpha)
# } else if ( is.matrix(.Object@beta) ) {
# .Object@dimens <- nrow(.Object@beta)
# } else if ( is.function(.Object@mu) ){
# .Object@dimens <- nrow(evalf(.Object@mu))
# } else if ( is.function(.Object@alpha) ){
# .Object@dimens <- nrow(evalf(.Object@alpha))
# } else if (is.function(.Object@beta) ){
# .Object@dimens <- nrow(evalf(.Object@beta))
# } else {
# stop("argument \"dimens\" is missing, with no default")
# }
# }
#
# Check spectral radius, only works for non marked model
if ( stability_check==TRUE && max(abs(eigen(alpha/beta)$values)) > 1)
warning("This model may not satisfy the stability condition.")
methods::callNextMethod()
.Object
}
)
setMethod("show", "hspec", function(object) {
cat("An object of class \"hsepc\" of ", object@dimens, "-dimensional Hawkes process", "\n\n", sep='')
if(!is.null(object@mu)){
cat("Slot mu: \n")
print(object@mu)
cat("\n")
}
if(!is.null(object@alpha)){
cat("Slot alpha: \n")
print(object@alpha)
cat("\n")
}
if(!is.null(object@beta)){
cat("Slot beta: \n")
print(object@beta)
cat("\n")
}
if(!is.null(object@eta)){
cat("Slot eta: \n")
print(object@eta)
cat("\n")
}
if(!is.null(object@impact)){
cat("Slot impact: \n")
print(object@impact)
cat("\n")
}
if(!is.null(object@type_col_map)){
cat("Slot type_col_map: \n")
print(object@type_col_map)
cat("\n")
}
if(!is.null(object@rmark)){
cat("Slot rmark: \n")
print(object@rmark)
cat("\n")
}
if(!is.null(object@dmark)){
cat("Slot dmark: \n")
print(object@dmark)
cat("\n")
}
})
Try the emhawkes package in your browser
Any scripts or data that you put into this service are public.
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.