-
Notifications
You must be signed in to change notification settings - Fork 0
/
prepare
111 lines (97 loc) · 3.86 KB
/
prepare
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
#************************************************************************************
prepare <- function(x, intercept, prior.mean, prior.sd, prior.scale, prior.df, group)
{
x0 <- x
if (intercept) x0 <- x[, -1, drop = FALSE]
g <- Grouping(all.var = colnames(x0), group = group)
group <- g$group
group.vars <- g$group.vars
ungroup.vars <- g$ungroup.vars
covars <- g$ungroup.vars
if (is.list(group)) { # for overlap groups
if (length(unlist(group)) > length(unique(unlist(group)))) {
x1 <- as.data.frame(x0)
x1 <- x1[, c(covars, unlist(group))]
g <- c(length(ungroup.vars), length(ungroup.vars) + cumsum(lapply(group, length)))
for (j in 1:(length(group)-1))
group.vars[[j]] <- colnames(x1[, (g[j]+1):g[j+1]])
x1 <- as.matrix(x1)
x <- x1
if (intercept) {
x <- cbind(1, x)
colnames(x)[1] <- "(Intercept)"
}
}
}
J <- NCOL(x)
if (intercept & J > 1) {
prior.mean <- c(0, prior.mean)
prior.scale <- c(prior.scale[1], prior.scale)
prior.df <- c(prior.df[1], prior.df)
}
if (length(prior.mean) < J)
prior.mean <- c(prior.mean, rep(prior.mean[length(prior.mean)], J - length(prior.mean)) )
if (length(prior.scale) < J)
prior.scale <- c(prior.scale, rep(prior.scale[length(prior.scale)], J - length(prior.scale)) )
if (length(prior.df) < J)
prior.df <- c(prior.df, rep(prior.df[length(prior.df)], J - length(prior.df)) )
prior.mean <- prior.mean[1:J]
prior.scale <- prior.scale[1:J]
prior.df <- prior.df[1:J]
prior.df <- ifelse(prior.df==Inf, 1e+10, prior.df)
if (is.null(prior.sd)) prior.sd <- prior.scale + 0.2 ## + 0.2 to avoid prior.sd=0
if (length(prior.sd) < J)
prior.sd <- c(prior.sd, rep(prior.sd[length(prior.sd)], J - length(prior.sd)) )
prior.sd <- prior.sd[1:J]
sd.x <- apply(x, 2, sd, na.rm=TRUE)
min.x.sd <- 1e-04
prior.sd <- ifelse(sd.x < min.x.sd, 1e-04, prior.sd)
if (intercept) prior.sd[1] <- 1e+10
names(prior.mean) <- names(prior.scale) <- names(prior.df) <- names(prior.sd) <- colnames(x)
if (intercept) covars <- c(colnames(x)[1], covars)
if (!is.null(covars)) prior.mean[covars] <- 0
list(x=x, prior.mean=prior.mean, prior.sd=prior.sd, prior.scale=prior.scale, prior.df=prior.df,
sd.x=sd.x, min.x.sd=min.x.sd,
group=group, group.vars=group.vars, ungroup.vars=ungroup.vars)
}
Grouping <- function(all.var, group)
{
n.vars <- length(all.var)
group.vars <- list()
if (is.matrix(group))
{
if (nrow(group)!=ncol(group) | ncol(group)>n.vars)
stop("wrong dimension for 'group'")
if (any(rownames(group)!=colnames(group)))
stop("rownames should be the same as colnames")
if (any(!colnames(group)%in%all.var))
stop("variabe names in 'group' not in the model predictors")
group.vars <- colnames(group)
group <- abs(group)
wcol <- rowSums(group) - diag(group)
group <- group/wcol
}
else{
if (is.list(group)) group.vars <- group
else
{
if (is.numeric(group) & length(group)>1) {
group <- sort(group)
if (group[length(group)] > n.vars) stop("wrong grouping")
}
if (is.numeric(group) & length(group)==1)
group <- as.integer(seq(0, n.vars, length.out = n.vars/group + 1))
if (is.null(group)) group <- c(0, n.vars)
group <- unique(group)
for (j in 1:(length(group) - 1))
group.vars[[j]] <- all.var[(group[j] + 1):group[j + 1]]
}
}
all.group.vars <- unique(unlist(group.vars))
if (length(all.group.vars) == n.vars) ungroup.vars <- NULL
else ungroup.vars <- all.var[which(!all.var %in% all.group.vars)]
group.new <- c(length(ungroup.vars), length(ungroup.vars) + cumsum(lapply(group.vars, length)))
var.new <- c(ungroup.vars, unlist(group.vars))
list(group=group, group.vars=group.vars, ungroup.vars=ungroup.vars,
group.new=group.new, var.new=var.new)
}