/
tawnT1Copula.R
152 lines (141 loc) · 4.95 KB
/
tawnT1Copula.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
#' Tawn copula models (type 1)
#'
#' S4-class representation of the Tawn Copula family of type 1 and rotated
#' versions there of.
#'
#'
#' @name tawnT1Copula-class
#' @aliases tawnT1Copula-class dduCopula,matrix,tawnT1Copula-method
#' dduCopula,numeric,tawnT1Copula-method ddvCopula,matrix,tawnT1Copula-method
#' ddvCopula,numeric,tawnT1Copula-method surTawnT1Copula-class
#' dduCopula,matrix,surTawnT1Copula-method
#' dduCopula,numeric,surTawnT1Copula-method
#' ddvCopula,matrix,surTawnT1Copula-method
#' ddvCopula,numeric,surTawnT1Copula-method r90TawnT1Copula-class
#' dduCopula,matrix,r90TawnT1Copula-method
#' dduCopula,numeric,r90TawnT1Copula-method
#' ddvCopula,matrix,r90TawnT1Copula-method
#' ddvCopula,numeric,r90TawnT1Copula-method r270TawnT1Copula-class
#' dduCopula,matrix,r270TawnT1Copula-method
#' dduCopula,numeric,r270TawnT1Copula-method
#' ddvCopula,matrix,r270TawnT1Copula-method
#' ddvCopula,numeric,r270TawnT1Copula-method
#' @docType class
#' @section Objects from the Class: Objects can be created by calls of the form
#' `new("tawnT1Copula", ...)`, or through the explicit constructors
#' [tawnT1Copula()], [surTawnT1Copula()],
#' [r90TawnT1Copula()] and [r270TawnT1Copula()]
#' respectively.
#' @seealso [tawnT1Copula-class] and the package
#' [VineCopula-package()] for implementation details.
#' @keywords classes
#' @examples
#'
#' showClass("tawnT1Copula")
NULL
#' @exportClass tawnT1Copula surTawnT1Copula r90TawnT1Copula r270TawnT1Copula
generateClass("tawnT1Copula")
generateClass("surTawnT1Copula")
generateClass("r90TawnT1Copula")
generateClass("r270TawnT1Copula")
#' Constructor for Tawn copulas (type 1)
#'
#' Constructs an object of the [tawnT1Copula-class] (survival
#' `sur`, 90 degree rotated `r90` and 270 degree rotated `r270`)
#' family for given parameters.
#'
#'
#' @aliases tawnT1Copula surTawnT1Copula r90TawnT1Copula r270TawnT1Copula
#' @param param The parameter `param` defines the copula through
#' `param1` and `param2`.
#' @return One of the Tawn type 1 copula classes
#' ([tawnT1Copula-class], [surTawnT1Copula-class],
#' [r90TawnT1Copula-class],
#' [r270TawnT1Copula-class]).
#' @seealso [tawnT1Copula()] and the package
#' [VineCopula-package()] for implementation details.
#' @keywords distribution copula
#' @examples
#'
#' library(copula)
#'
#' persp(tawnT1Copula(), dCopula, zlim = c(0, 10))
#' persp(surTawnT1Copula(), dCopula, zlim = c(0, 10))
#' persp(r90TawnT1Copula(), dCopula, zlim = c(0, 10))
#' persp(r270TawnT1Copula(), dCopula, zlim = c(0, 10))
#' @export
tawnT1Copula <- function(param = c(2, 0.5)) {
new("tawnT1Copula",
dimension = as.integer(2),
parameters = param,
param.names = c("param1", "param2"),
param.lowbnd = c(1, 0),
param.upbnd = c(Inf, 1),
family = 104,
fullname = "Tawn type 1 copula family. Number 104 in VineCopula."
)
}
#' @export
#' @rdname tawnT1Copula
surTawnT1Copula <- function(param = c(2, 0.5)) {
new("surTawnT1Copula",
dimension = as.integer(2),
parameters = param,
param.names = c("param1", "param2"),
param.lowbnd = c(1, 0),
param.upbnd = c(Inf, 1),
family = 114,
fullname = "Survival Tawn type 1 copula family. Number 114 in VineCopula."
)
}
#' @export
#' @rdname tawnT1Copula
r90TawnT1Copula <- function(param = c(-2, 0.5)) {
new("r90TawnT1Copula",
dimension = as.integer(2),
parameters = param,
param.names = c("param1", "param2"),
param.lowbnd = c(-Inf, 0),
param.upbnd = c(-1, 1),
family = 124,
fullname = "90 deg rotated Tawn type 1 copula family. Number 124 in VineCopula."
)
}
#' @export
#' @rdname tawnT1Copula
r270TawnT1Copula <- function(param = c(-2, 0.5)) {
new("r270TawnT1Copula",
dimension = as.integer(2),
parameters = param,
param.names = c("param1", "param2"),
param.lowbnd = c(-Inf, 0),
param.upbnd = c(-1, 1),
family = 134,
fullname = "270 deg rotated Tawn type 1 copula family. Number 134 in VineCopula."
)
}
# Pickand's A
# c-code: Tawn1(double* t, int* n, double* par, double* par2, double* par3, double* out)
setMethod("A", signature("tawnT1Copula"), function(copula, w) {
.C("Tawn2", as.double(w), as.integer(length(w)),
as.double(copula@parameters[1]), as.double(copula@parameters[2]),
as.double(1), as.double(rep(0, length(w))),
PACKAGE = "VC2copula"
)[[6]]
})
# c-code: Tawn1(double* t, int* n, double* par, double* par2, double* par3, double* out)
setMethod("A", signature("surTawnT1Copula"), function(copula, w) {
u <- -expm1(-1 + w)
v <- -expm1(-w)
surA <- .C("Tawn2", as.double(log(v) / log(u * v)), as.integer(length(w)),
as.double(copula@parameters[1]), as.double(copula@parameters[2]),
as.double(1), as.double(rep(0, length(w))),
PACKAGE = "VC2copula"
)[[6]]
-log(1 - u + 1 - v - 1 + (u * v)^surA)
})
# fitCopula
setMethod(fitCopula, "tawnT1Copula", BCfitCopula)
setMethod(fitCopula, "surTawnT1Copula", BCfitCopula)
setMethod(fitCopula, "r90TawnT1Copula", BCfitCopula)
setMethod(fitCopula, "r270TawnT1Copula", BCfitCopula)