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
|
hdxp0 <- function(x,span) {
y <- matrix(rep("",span),nrow=1,ncol=span)
y[,1] <- x
y
}
hdxp1 <- function(x) {
span <- attr(x,"span")
y <- matrix(rep("",span),nrow=1,ncol=span)
y[,1] <- x
y
}
hdxp <- function(x)do.call(cbind,lapply(x,hdxp1))
ldxp1 <- function(x) {
span <- attr(x,"span")
y <- matrix(rep("",span),nrow=span,ncol=1)
y[1,] <- x
y
}
ldxp <- function(x)do.call(rbind,lapply(x,ldxp1))
mtable_format_delim <- function(x,
colsep="\t",
rowsep="\n",
interaction.sep = " x ",
...)
pf_mtable_format_delim(preformat_mtable(x),
colsep=colsep,
rowsep=rowsep,
interaction.sep = interaction.sep,
...)
pf_mtable_format_delim <- function(x,
colsep="\t",
rowsep="\n",
interaction.sep = " x ",
show.parmtypes = nrow(x$parmtab) > 1,
...
){
pt <- x$parmtab
sst <- x$summary.stats
sh <- x$sect.headers
leaders <- x$leaders
headers <- x$headers
eq.headers <- x$eq.headers
res <- NULL
l.headers <- length(headers)
l.leaders <- length(leaders)
has.eq.headers <- length(eq.headers) > 0
for(j in 1:ncol(pt)){
name.j <- colnames(pt)[j]
pt.j <- pt[,j]
l.pt.j <- length(pt.j)
ncol.j <- unique(sapply(pt.j,ncol))
stopifnot(length(ncol.j)==1)
for(i in 1:l.pt.j){
pt.ij <- pt.j[[i]]
if(show.parmtypes){
pt.ij <- rbind(" ",pt.ij)
}
pt.j[[i]] <- pt.ij
}
pt.j <- do.call(rbind,pt.j)
if(has.eq.headers){
eq.header.j <- eq.headers[[name.j]]
n.eq.j <- length(eq.header.j)
eq.span <- ncol(pt.j)/n.eq.j
tmp <- matrix("",ncol=n.eq.j,nrow=eq.span)
tmp[1,] <- eq.header.j
eq.header.j <- as.vector(tmp)
pt.j <- rbind(eq.header.j,pt.j)
}
if(length(sst)){
sst.j <- sst[[j]]
sst.j <- colexpand(sst.j,ncol.j)
pt.j <- rbind(pt.j,sst.j)
}
res <- cbind(res,pt.j)
}
if(l.headers){
for(k in 1:l.headers){
headers.k <- headers[[k]]
headers.k <- lapply(headers.k,hdxp1)
headers.k <- do.call(cbind,headers.k)
headers[[k]] <- headers.k
}
headers <- do.call(rbind,headers)
res <- rbind(headers,res)
}
if(l.leaders){
lh <- l.headers + has.eq.headers
if(lh)
leaders <- c(rep(list(list(structure("",span=1))),lh),
leaders)
leaders <- lapply(leaders,ldxp)
if(show.parmtypes){
parmtypes <- rownames(x$parmtab)
for(p in parmtypes){
leaders[[p]] <- rbind(p,leaders[[p]])
}
}
leaders <- do.call(rbind,leaders)
res <- cbind(leaders,res)
}
res <- apply(res,1,paste,collapse=colsep)
res <- paste0(res,rowsep)
return(res)
}
|
