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
|
BFBayesFactorList<- function(li){
col_nms = sapply(li,function(el) el@denominator@shortName)
names(li) = make.unique(col_nms, sep=" #")
new("BFBayesFactorList", li, version=BFInfo(FALSE))
}
setValidity("BFBayesFactorList", function(object){
firstNumerator = object[[1]]@numerator
sameNumerators = unlist(lapply(object, function(el, firstNumerator) {
identical(el@numerator,firstNumerator)
}, firstNumerator = firstNumerator))
if(any(!sameNumerators)) return("All numerators in elements of BayesFactorList must be identical")
return(TRUE)
})
setMethod('show', "BFBayesFactorList", function(object){
print(as(object,"matrix"))
})
#' @rdname BFBayesFactorList-class
#' @name t,BFBayesFactorList-method
#' @param x a BFBayesFactorList object
setMethod('t', "BFBayesFactorList", function(x){
return(1/x)
})
#' @rdname BFBayesFactorList-class
#' @name /,numeric,BFBayesFactorList-method
#' @param e1 Numerator of the ratio
#' @param e2 Denominator of the ratio
setMethod('/', signature("numeric", "BFBayesFactorList"), function(e1, e2){
if( (e1 == 1) & (length(e2[[1]])==1) ){
bflist = lapply(e2,function(el) 1/el)
return(do.call('c',bflist))
}else if( e1 != 1 ){
stop("Dividend must be 1 (to take reciprocal).")
}else if( length(e2[[1]])>1 ){
vec = vector(mode = "list", length = length(e2[[1]]))
for(i in 1:length(e2[[1]])){
vec[[i]] = 1/e2[i,]
}
bflist = BFBayesFactorList(vec)
return(bflist)
}
}
)
#' @rdname BFBayesFactorList-class
#' @name [,BFBayesFactorList,index,index,missing-method
#' @param i indices specifying rows to extract
#' @param j indices specifying columns to extract
#' @param drop unused
#' @param ... further arguments passed to related methods
setMethod("[", signature(x = "BFBayesFactorList", i = "index", j = "index",
drop = "missing"),
function (x, i, j, ..., drop) {
if((na <- nargs()) == 3){
x = x[i,][,j]
}else stop("invalid nargs()= ",na)
return(x)
})
#' @rdname BFBayesFactorList-class
#' @name [,BFBayesFactorList,index,missing,missing-method
setMethod("[", signature(x = "BFBayesFactorList", i = "index", j = "missing",
drop = "missing"),
function (x, i, j, ..., drop) {
if((na <- nargs()) == 3){
bfs = lapply(x,function(el,i) el[i], i = i)
x = BFBayesFactorList(bfs)
}else stop("invalid nargs()= ",na)
return(x)
})
#' @rdname BFBayesFactorList-class
#' @name [,BFBayesFactorList,missing,index,missing-method
setMethod("[", signature(x = "BFBayesFactorList", i = "missing", j = "index",
drop = "missing"),
function (x, i, j, ..., drop) {
if((na <- nargs()) == 3){
if(length(j)==1){
x = x[[j]]
}else if(length(j)>1){
x = as(x, "vector")
x = BFBayesFactorList(x[j])
}
}else stop("invalid nargs()= ",na)
return(x)
})
setAs("BFBayesFactorList" , "list",
function ( from , to ){
as.vector(from)
})
setAs("BFBayesFactorList" , "vector",
function ( from , to ){
as.vector(from)
})
setAs("BFBayesFactorList" , "matrix",
function ( from , to ){
as.matrix(from)
})
## S3 Methods
#####
as.vector.BFBayesFactorList <- function(x, mode = "any"){
if( !(mode %in% c("any", "list"))) stop("Cannot coerce to mode ", mode)
vec = vector(mode = "list", length = length(x) )
for(i in 1:length(x))
vec[[i]] = x[[i]]
names(vec) = names(x)
return(vec)
}
as.matrix.BFBayesFactorList <- function(x,...){
matr <- sapply(x, as.vector)
dim(matr) <- c(length(x[[1]]),length(x))
numNames <- rownames(extractBF(x[[1]]))
denNames <- names(x)
dimnames(matr) = list(numerator=numNames, denominator=denNames)
return(as.matrix(matr))
}
|
