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
|
valid.n<-function(x,na.rm=TRUE) return(ifelse(na.rm,sum(!is.na(x)),length(x)))
propbrk<-function(x,trueval=TRUE,na.rm=TRUE) {
return(sum(x==trueval,na.rm=TRUE)/length(x))
}
sumbrk<-function(x,trueval=TRUE,na.rm=TRUE) {
return(sum(x==trueval,na.rm=TRUE))
}
binciWu<-function(x,n,alpha=0.05,trueval=NA,na.rm=TRUE) {
if(!is.na(trueval)) {
n<-length(x)
x<-sum(x==trueval,na.rm=TRUE)
}
z<-pnorm(1-alpha/2)
zsq<-z*z
phat<-ifelse(x<1,x,x/n)
pest<-phat+zsq/(2*n)
ci<-(pest+z*sqrt((phat*(1-phat))/n+zsq/(4*n*n)))/(1+zsq/n)
return(ci)
}
binciWl<-function(x,n,alpha=0.05,trueval=NA,na.rm=TRUE) {
if(!is.na(trueval)) {
n<-length(x)
x<-sum(x==trueval,na.rm=TRUE)
}
z<-pnorm(1-alpha/2)
zsq<-z*z
phat<-ifelse(x<1,x,x/n)
pest<-phat+zsq/(2*n)
ci<-(pest-z*sqrt((phat*(1-phat))/n+zsq/(4*n*n)))/(1+zsq/n)
return(ci)
}
brkdnNest<-function(formula,data,FUN=c("mean","sd"),label1="Overall",
trueval = NA) {
if(missing(data) || missing(formula))
stop("brkdnNest must be called with a formula for breakdown and a data frame.")
bn<-as.character(attr(terms(formula),"variables")[-1])
nbn<-length(bn)
nFUN<-length(FUN)
brklist<-vector("list",nFUN)
for(brkfun in 1:nFUN) {
brklist[[brkfun]]<-vector("list",nbn)
# get the overall values
if(is.na(trueval))
brklist[[brkfun]][[1]]<-
do.call(FUN[brkfun],list(data[[bn[1]]],na.rm=TRUE))
else
brklist[[brkfun]][[1]]<-
do.call(FUN[brkfun],list(data[[bn[1]]],trueval=trueval,na.rm=TRUE))
names(brklist[[brkfun]][[1]])<-label1
for(brk in 2:nbn) {
if(is.na(trueval))
brklist[[brkfun]][[brk]]<-
tapply(data[[bn[1]]],data[bn[2:brk]],FUN=match.fun(FUN[brkfun]),
na.rm=TRUE)
else
brklist[[brkfun]][[brk]]<-
tapply(data[[bn[1]]],data[bn[2:brk]],FUN=match.fun(FUN[brkfun]),
trueval=trueval)
names(brklist[[brkfun]][[brk]])<-levels(data[[brkfun[brk]]])
}
}
attr(brklist,"class")<-"brklist"
names(brklist)<-FUN
return(brklist)
}
sliceArray<-function(x,slice) {
dimx<-dim(x)
if(is.null(dimx)) return(x[slice])
else {
ndim<-length(dimx)
slicestring<-
paste("x[",slice,paste(rep(",",ndim-1),collapse=""),"]",sep="",collapse="")
newx<-eval(parse(text=slicestring))
return(newx)
}
}
print.brklist<-function(x,...) {
crawlBreakList<-function(x,depth=1) {
if(length(x)>1) {
if(depth==1) cat(names(x[[1]]),unlist(x[[1]]),"\n")
x[[1]]<-NULL
for(nextbit in 1:length(x[[1]])) {
newx<-lapply(x,sliceArray,nextbit)
cat(rep("\t",depth),names(x[[1]][nextbit]),unlist(x[[1]][nextbit]),"\n")
crawlBreakList(newx,depth=depth+1)
}
}
}
xnames<-names(x)
for(func in 1:length(x)) {
cat(xnames[func],"\n")
crawlBreakList(x[[func]])
}
}
|
