1str.has <- function(text,has,not=NULL,how=c("all","any")){
2    how <- match.fun(match.arg(how))
3
4    hasit <- sapply(has,function(pat)regexpr(pat,text,fixed=TRUE) > 0)
5    if(is.matrix(hasit))
6        hasit <- apply(hasit,1,how)
7    else
8        hasit <- all(hasit)
9
10
11    if(!length(not)) return(hasit)
12    # else
13    hasnot <- sapply(not,function(pat)regexpr(pat,text,fixed=TRUE) > 0)
14    if(is.matrix(hasnot))
15        hasnot <- apply(hasnot,1,how)
16    else
17        hasnot <- all(hasnot)
18
19    hasit & !hasnot
20}
21
22
23
24setCoefTemplate <- function(...){
25  args <- list(...)
26  argnames <- names(args)
27  CoefTemplates <- get("CoefTemplates", envir=.memiscEnv)
28  OldCoefTemplates <- CoefTemplates
29    for(coef.style in argnames){
30      CoefTemplates[[coef.style]] <- args[[coef.style]]
31  }
32  assign("CoefTemplates",CoefTemplates, envir=.memiscEnv)
33  return(invisible(OldCoefTemplates))
34}
35
36getFirstMatch <- function(x,n){
37  for(n. in n){
38    if(n. %in% names(x)) return(x[[n.]])
39  }
40  return(x[["default"]])
41}
42
43getCoefTemplate <- function(style){
44  CoefTemplates <- get("CoefTemplates", envir=.memiscEnv)
45  if(missing(style)) return(CoefTemplates)
46  else return(CoefTemplates[[style]])
47}
48
49
50getSummary <- function(obj,alpha=.05,...) UseMethod("getSummary")
51# setGeneric("getSummary")
52
53summaryTemplate <- function(x)
54  UseMethod("summaryTemplate")
55
56getFirstS3method <- function(mname,cls,optional){
57    for(cls1 in cls){
58        mfun <- getS3method(mname,cls1,optional)
59        if(length(mfun)) return(mfun)
60    }
61    return(NULL)
62}
63
64getSummaryTemplate <- function(x){
65  SummaryTemplates <- get("SummaryTemplates", envir=.memiscEnv)
66  if(missing(x)) return(SummaryTemplates)
67  if(is.character(x)) cls <- x
68  else cls <- class(x)
69  stf <- getFirstS3method("summaryTemplate",cls,optional=TRUE)
70  if(length(stf))
71    res <- stf(x)
72  else
73    res <- getFirstMatch(SummaryTemplates,cls)
74  return(res)
75}
76
77setSummaryTemplate <- function(...){
78  args <- list(...)
79  argnames <- names(args)
80  OldSummaryTemplates <- SummaryTemplates <- get("SummaryTemplates", envir=.memiscEnv)
81  for(cls in argnames){
82      SummaryTemplates[[cls]] <- args[[cls]]
83  }
84  assign("SummaryTemplates",SummaryTemplates,envir=.memiscEnv)
85  return(invisible(OldSummaryTemplates))
86}
87
88selectSummaryStats <- function(x,n) {
89    if(is.character(n)){
90        n
91    }
92    else if(isTRUE(n)){
93        cls <- class(x)
94        sumstats.name <- paste0("summary.stats.",cls)
95        sumstats <- lapply(sumstats.name,getOption)
96        if(any(!vapply(sumstats, is.null, TRUE))){
97            sumstats <- unlist(sumstats)
98            sumstats[1]
99        }
100        else
101            sumstats <- getOption("summary.stats.default")
102        sumstats
103    }
104    else FALSE
105}
106
107prettyNames <- function(coefnames,
108                        contrasts,
109                        xlevels,
110                        factor.style,
111                        show.baselevel,
112                        baselevel.sep
113                        ){
114    termorders <- sapply(strsplit(coefnames,":",fixed=TRUE),length)
115    ordergroups <- split(coefnames,termorders)
116    ordergroups <- lapply(ordergroups,prettyNames1,
117                        contrasts=contrasts,
118                        xlevels=xlevels,
119                        factor.style=factor.style,
120                        show.baselevel=show.baselevel,
121                        baselevel.sep=baselevel.sep
122                        )
123    unsplit(ordergroups,termorders)
124}
125
126prettyNames1 <- function(str,
127                        contrasts,
128                        xlevels,
129                        factor.style,
130                        show.baselevel,
131                        baselevel.sep
132                        ){
133   str <- gsub(":"," x ",str,fixed=TRUE)
134   for(f in names(contrasts)){
135      contrast.f <- contrasts[[f]]
136      levels <- xlevels[[f]]
137      #if(!length(levels)) levels <- c("FALSE","TRUE")
138      if(!length(levels)) {
139        str <- gsub(paste(f,"TRUE",sep=""),f,str,fixed=TRUE)
140        next
141      }
142      if(is.character(contrast.f))
143        contrast.matrix <- do.call(contrast.f,list(n=levels))
144      else if(is.matrix(contrast.f))
145        contrast.matrix <- contrast.f
146      levels.present <- sapply(levels,function(level)
147            any(str.has(str,c(f,level)))
148            )
149      if(all(levels.present))
150        oldlabels <- newlabels <- levels
151      else if(!length(colnames(contrast.matrix))){
152        oldlabels <- newlabels <- as.character(1:ncol(contrast.matrix))
153        }
154      else if(is.character(contrast.f) &&
155          contrast.f %in% c(
156              "contr.treatment",
157              "contr.SAS"
158              )){
159         baselevel <- setdiff(rownames(contrast.matrix),colnames(contrast.matrix))
160         if(show.baselevel)
161           newlabels <- paste(colnames(contrast.matrix),baselevel,sep=baselevel.sep)
162         else
163           newlabels <- colnames(contrast.matrix)
164         oldlabels <- colnames(contrast.matrix)
165      }
166      else if(is.character(contrast.f) &&
167          contrast.f %in% c(
168              "contr.sum",
169              "contr.helmert"
170              )){
171         newlabels <- apply(contrast.matrix,2,
172                                          function(x)rownames(contrast.matrix)[x>=1])
173         oldlabels <- colnames(contrast.matrix)
174      }
175      else if(
176        all(colnames(contrast.matrix) %in% rownames(contrast.matrix))
177        ){
178         baselevel <- setdiff(rownames(contrast.matrix),colnames(contrast.matrix))
179         if(show.baselevel)
180           newlabels <- paste(colnames(contrast.matrix),baselevel,sep=baselevel.sep)
181         else
182           newlabels <- colnames(contrast.matrix)
183         oldlabels <- colnames(contrast.matrix)
184      }
185      else {
186        oldlabels <- newlabels <- colnames(contrast.matrix)
187      }
188      from <- paste(f,oldlabels,sep="")
189      to <- sapply(newlabels,
190        function(l)applyTemplate(c(f=f,l=l),template=factor.style))
191      for(i in 1:length(from))
192        str <- gsub(from[i],to[i],str,fixed=TRUE)
193   }
194   str
195}
196
197bind_arrays <- function(args,along=1){
198  along.dn <- unlist(lapply(args,function(x)dimnames(x)[[along]]))
199  groups <- sapply(args,function(x)dim(x)[along])
200  dn <- dimnames(args[[1]])
201  keep.dn <- dn[-along]
202  dim1 <- dim(args[[1]])
203  keep.dim <- dim1[-along]
204  ldim <- length(dim1)
205  dimseq <- seq_len(ldim)
206  perm.to <- dimseq
207  perm.to[ldim] <- along
208  perm.to[along] <- ldim
209  res <- lapply(args,function(x){
210    x <- aperm(x,perm.to)
211    dim(x) <- c(prod(dim(x)[-ldim]),dim(x)[ldim])
212    x
213    })
214  res <- do.call(cbind,res)
215  dim(res) <- c(keep.dim,ncol(res))
216  dimnames(res) <- c(keep.dn,list(along.dn))
217  structure(aperm(res,perm.to),groups=groups)
218}
219
220names.or.rownames <- function(x){
221    if(is.array(x)) rownames(x)
222    else names(x)
223}
224
225mtable <- function(...,
226                   coef.style=getOption("coef.style"),
227                   summary.stats=TRUE,
228                   signif.symbols=getOption("signif.symbols"),
229                   factor.style=getOption("factor.style"),
230                   show.baselevel=getOption("show.baselevel"),
231                   baselevel.sep=getOption("baselevel.sep"),
232                   getSummary=eval.parent(quote(getSummary)),
233                   float.style=getOption("float.style"),
234                   digits=min(3,getOption("digits")),
235                   sdigits=digits,
236                   show.eqnames=getOption("mtable.show.eqnames",NA),
237                   gs.options=NULL,
238                   controls=NULL,
239                   collapse.controls=FALSE,
240                   control.var.indicator=getOption("control.var.indicator",c("Yes","No"))
241                   ){
242  args <- list(...)
243  if(length(args)==1 && inherits(args[[1]],"by"))
244    args <- args[[1]]
245  argnames <- names(args)
246  if(!length(argnames)) {
247    m <- match.call(expand.dots=FALSE)
248    argnames <- sapply(m$...,paste)
249  }
250  n.args <- length(args)
251
252  arg.classes <- lapply(args,class)
253  if(any(sapply(arg.classes,length))==0) stop("don\'t know how to handle these arguments")
254
255  if(length(gs.options)){
256    summaries.call <- as.call(
257      c(list(as.name("lapply"),
258             as.name("args"),
259             FUN=as.name("getSummary")),
260        gs.options
261      ))
262    summaries <- eval(summaries.call)
263  }
264  else
265    summaries <- lapply(args,getSummary)
266
267  parameter.types <- unique(unlist(lapply(summaries,names)))
268  parameter.types <- parameter.types[parameter.types %nin% c("sumstat","contrasts","call","xlevels")]
269  parmnames <- list()
270  for(pt in parameter.types){
271
272      tmp.pn <- lapply(summaries,`[[`,pt)
273      tmp.pn <- lapply(tmp.pn,names.or.rownames)
274      parmnames[[pt]] <- unique(unlist(tmp.pn))
275  }
276  parameter.names <- unique(unlist(parmnames))
277
278  stemplates <- lapply(args,getSummaryTemplate)
279  if(isTRUE(summary.stats))
280      summary.stats <- lapply(args,selectSummaryStats,TRUE)
281  else if(is.character(summary.stats))
282      summary.stats <- lapply(args,selectSummaryStats,summary.stats)
283  else if(is.list(summary.stats)){
284      tmp.summary.stats <- summary.stats
285      summary.stats <- vector(mode="list",length=length(args))
286      summary.stats[] <- tmp.summary.stats
287  } else {
288      summary.stats <- vector(mode="list",length=length(args))
289      summary.stats[] <- list(FALSE)
290  }
291
292  if(length(controls)){
293      if(is.character(controls))
294          controls <- asOneSidedFormula(controls)
295      if(inherits(controls,"formula")){
296          control.coefs <- lapply(args,formula2coefs,fo=controls)
297          control.terms <- lapply(args,formula2termlabs,fo=controls)
298      }
299      else
300          stop("'controls=' must be a formula or a character vector.")
301      controls <- list(coefs=control.coefs,terms=control.terms)
302  }
303
304  structure(summaries,
305            names=argnames,
306            class="memisc_mtable",
307            parameter.names=parameter.names,
308            coef.style=coef.style,
309            summary.stats=summary.stats,
310            signif.symbols=signif.symbols,
311            factor.style=factor.style,
312            show.baselevel=show.baselevel,
313            baselevel.sep=baselevel.sep,
314            float.style=float.style,
315            digits=digits,
316            stemplates=stemplates,
317            sdigits=sdigits,
318            show.eqnames=show.eqnames,
319            controls=controls,
320            collapse.controls=collapse.controls,
321            control.var.indicator=control.var.indicator
322            )
323
324}
325
326prefmt1 <- function(parm,template,float.style,digits,signif.symbols,controls){
327
328    rn <- rownames(parm)
329    if(length(intersect(rn,controls))){
330        controls <- intersect(rn,controls)
331        rn <- setdiff(rn,controls)
332        if(length(dim(parm))==2)
333            parm <- parm[rn,,drop=FALSE]
334        else
335            parm <- parm[rn,,,drop=FALSE]
336    }
337    else controls <- NULL
338    adims <- if(length(dim(parm))==2) 1 else c(1,3)
339    if(length(parm)){
340
341        if(is.array(parm)){
342            ans <- apply(parm,adims,applyTemplate,
343                         template=template,
344                         float.style=float.style,
345                         digits=digits,
346                         signif.symbols=signif.symbols)
347        }
348        else {
349            ans <- array(formatC(parm,
350                                 digits=digits,
351                                 ifelse(is.integer(parm),
352                                        "d","f"),
353                                 width=1),
354                         dim=c(1,1,length(parm),1),
355                         dimnames=list(NULL,NULL,names(parm),NULL))
356            return(ans)
357        }
358    }
359    else {
360        ans <- array(character(0),
361                     dim=c(0,dim(parm)[adims]),
362                     dimnames=c(list(NULL),dimnames(parm)[adims]))
363    }
364
365    if(length(dim(template))){
366        newdims <- c(dim(template),dim(ans)[-1])
367        newdimnames <- c(dimnames(template),dimnames(ans)[-1])
368
369        # for(i in 1:length(newdims)){
370        #     if(!length(newdimnames[[i]])){
371        #         if(newdims[i]==0)
372        #             newdimnames[[i]] <- character(0)
373        #         else
374        #             newdimnames[[i]] <- as.character(1:newdims[i])
375        #     }
376        # }
377
378        dim(ans) <- newdims
379        dimnames(ans) <- newdimnames
380    } else rownames(ans) <- names(template)
381
382    ans[ans=="()"] <- ""
383    attr(ans,"controls") <- controls
384    return(ans)
385}
386
387prefmt2 <- function(parm){
388
389    if(length(dim(parm))<4)
390        dim(parm)[4] <- 1
391
392    parm <- aperm(parm,c(1,3,2,4))
393    dim(parm) <- c(prod(dim(parm)[1:2]),prod(dim(parm)[3:4]))
394
395    parm
396}
397
398colexpand <- function(x,nc){
399    x.nr <- nrow(x)
400    x.nc <- ncol(x)
401    y <- matrix("",nrow=x.nr,ncol=max(nc,1))
402    if(length(x))
403        y[,1:x.nc] <- x
404    y
405}
406
407rowexpand <- function(x,nr){
408    x.nr <- nrow(x)
409    x.nc <- ncol(x)
410    y <- matrix("",nrow=nr,ncol=x.nc)
411    if(length(x))
412        y[1:x.nr,] <- x
413    y
414}
415
416
417dimnames3 <- function(x)dimnames(x)[[3]]
418
419getRows <- function(x,r){
420    if(is.character(r))
421        r <- intersect(r,rownames(x))
422    x[r,,drop=FALSE]
423}
424get_rows <- function(x,i)try(x[i,,drop=FALSE])
425
426relabel.memisc_mtable <- function(x,...,gsub=FALSE,fixed=!gsub,warn=FALSE){
427
428    relab.req <- list(...,
429                      gsub=gsub,fixed=fixed,warn=warn)
430
431    relab.attr <- attr(x,"relabel")
432    if(!length(relab.attr))
433        relab.attr <-list(relab.req)
434    else
435        relab.attr <-c(relab.attr,
436                       list(relab.req))
437
438    attr(x,"relabel") <- relab.attr
439
440    x
441}
442
443pt_getrow <- function(x,i){
444    y <- x[i,]
445    isn <- sapply(y,is.null)
446    if(any(isn)) return(y[!isn])
447    else return(y)
448}
449
450do_subs <- function(x,r){
451    for(rr in r)
452        x <- do_1sub(x,rr)
453    return(x)
454}
455
456do_1sub <- function(x,r){
457
458    r.gsub <- r$gsub
459    r.fixed <- r$fixed
460
461    r <- r[names(r)%nin%c("gsub","fixed","warn")]
462
463    y <- x
464    for(i in seq_along(r)){
465        from <- names(r)[i]
466        to <- r[[i]]
467        if(r.gsub)
468            y <- gsub(from,to,y,fixed=r.fixed)
469        else {
470            y[y==from] <- to
471        }
472    }
473    return(y)
474}
475
476do_prettyfy <- function(pn,
477                        contrasts,
478                        xlevels,
479                        factor.style,
480                        show.baselevel,
481                        baselevel.sep){
482
483    if(!length(contrasts)) return(pn)
484
485    res <- pn
486
487    done <- res != pn
488
489    for(m in names(contrasts)){
490        contrasts.m <- contrasts[[m]]
491        xlevels.m <- xlevels[[m]]
492        if(all(done)) break
493        pn.tmp <- pn[!done]
494        pn.tmp  <- prettyNames(pn.tmp,
495                               contrasts=contrasts.m,
496                               xlevels=xlevels.m,
497                               factor.style=factor.style,
498                               show.baselevel=show.baselevel,
499                               baselevel.sep=baselevel.sep)
500        res[!done] <- pn.tmp
501        done <- res != pn
502    }
503
504    return(res)
505}
506
507nzchar_row <- function(x){
508    nzch <- array(nzchar(x),dim=dim(x))
509    apply(nzch,1,any)
510}
511
512dropnull <- function(x) {
513    ii <- sapply(x,is.null)
514    x[!ii]
515}
516ni <- function(tab,x) x%in%tab
517preformat_mtable <- function(x){
518
519    x <- unclass(x)
520
521    coef.style <- attr(x,"coef.style")
522    summary.stats <- attr(x,"summary.stats")
523    signif.symbols <- attr(x,"signif.symbols")
524    factor.style <- attr(x,"factor.style")
525    show.baselevel <- attr(x,"show.baselevel")
526    baselevel.sep <- attr(x,"baselevel.sep")
527    float.style <- attr(x,"float.style")
528    digits <- attr(x,"digits")
529    stemplates <- attr(x,"stemplates")
530    sdigits <- attr(x,"sdigits")
531
532    allcompo <- unique(unlist(lapply(x,names)))
533    nonparnames <- c("sumstat","contrasts","xlevels","call")
534    partypes <- setdiff(allcompo,nonparnames)
535
536    sumstats <- lapply(x,`[[`,"sumstat")
537    contrasts <- lapply(x,`[[`,"contrasts")
538    xlevels <- lapply(x,`[[`,"xlevels")
539    calls <- lapply(x,`[[`,"call")
540    parms <- lapply(x,`[`,partypes)
541    parms <- lapply(parms,dropnull)
542
543    ctemplate <- getCoefTemplate(coef.style)
544    if(!length(ctemplate)) stop("invalid coef.style argument")
545    ctemplate <- as.matrix(ctemplate)
546    ctdims <- dim(ctemplate)
547    lctdims <- length(ctdims)
548    if(lctdims>2) stop("can\'t handle templates with dim>2")
549
550    relab.attr <- attr(x,"relabel")
551
552    modelnames <- names(x)
553    modelgroups <- attr(x,"model.groups")
554
555    force.header <- isTRUE(attr(x,"force.header")) # Document that later ...
556    show.eqnames <- attr(x,"show.eqnames")
557
558    all.control.terms <- NULL
559    control.terms <- NULL
560    control.coefs <- NULL
561    controls <- attr(x,"controls")
562    collapse.controls <- attr(x,"collapse.controls")
563    if(length(controls)){
564        control.terms <- controls$terms
565        control.coefs <- controls$coefs
566        control.coefs <- unique(unlist(control.coefs))
567
568        all.control.terms <- unique(unlist(control.terms))
569    }
570
571    parmtab <- NULL
572
573    ct.indicator <- attr(x,"control.var.indicator")
574    if(!length(ct.indicator)) ct.indicator <- c("X","")
575
576    if(length(partypes)){
577        for(n in 1:length(parms)){
578
579            parms.n <- parms[[n]]
580            parms.n<- lapply(parms.n,
581                             prefmt1,
582                             template=ctemplate,
583                             float.style=float.style,
584                             digits=digits,
585                             signif.symbols=signif.symbols,
586                             controls=control.coefs)
587            if(length(control.terms)){
588                ct <- control.terms[[n]]
589                ct <- all.control.terms %in% ct
590                if(collapse.controls) {
591                    if(all(ct))
592                        ct <- ct.indicator[1]
593                    else if(!any(ct))
594                        ct <- ct.indicator[2]
595                    else
596                        ct <- as.character(NA)
597                    dim(ct) <- c(1,1,1,1)
598                    dimnames(ct) <- list(1,2,"Controls",3)
599                }
600                else {
601                    ct <- ifelse(ct,ct.indicator[1],ct.indicator[2])
602                    dim(ct) <- c(1,1,length(ct),1)
603                    dimnames(ct) <- list(1,2,all.control.terms,3)
604                }
605                parms.n <- append(parms.n,list(Controls=ct),after=1)
606            }
607            parms[[n]] <- parms.n
608        }
609        if(length(control.terms))
610            partypes <- append(partypes,"Controls",after=1)
611        parmtab <- array(list(),
612                  dim=c(length(partypes),length(parms)),
613                  dimnames=list(partypes,names(parms)))
614
615        for(n in 1:length(parms)){
616            mod <- parms[[n]]
617            modnames <- names(mod)
618            for(m in modnames){
619                mod.m <- mod[[m]]
620                parmtab[[m,n]] <- mod.m
621            }
622        }
623
624        parameter.names <- attr(x,"parameter.names")
625        parmnames <- list()
626
627        for(m in rownames(parmtab)){
628            tmp.pn <- lapply(parmtab[m,],dimnames3)
629            tmp.pn <- unique(unlist(tmp.pn))
630            tmp.pn <- parameter.names[parameter.names %in% tmp.pn]
631            parmnames[[m]] <- tmp.pn
632        }
633        if(length(all.control.terms)){
634            if(collapse.controls)
635                parmnames$Controls <- "Controls"
636            else
637                parmnames$Controls <- all.control.terms
638        }
639        # Make sure that columns and rows match across models
640        for(n in 1:ncol(parmtab)){
641            mod <- parms[[n]]
642            for(m in rownames(parmtab)){
643                parmtab.mn <- parmtab[[m,n]]
644                if(length(parmnames[[m]])){
645                    parmtab.mn <- coefxpand(parmtab.mn,parmnames[[m]])
646                    parmtab.mn <- prefmt2(parmtab.mn)
647                    parmtab[[m,n]] <- parmtab.mn
648                }
649                modm <- mod[[m]]
650            }
651            maxncol <- max(unlist(lapply(parmtab[,n],ncol)) )
652            parmtab[,n] <- lapply(parmtab[,n],colexpand,maxncol)
653        }
654        # Drop empty rows
655        for(n in 1:nrow(parmtab)){
656            maxnrow <- max(unlist(lapply(parmtab[n,],nrow)) )
657            parmtab[n,] <- lapply(parmtab[n,],rowexpand,maxnrow)
658            nz <- lapply(parmtab[n,],nzchar_row)
659            if(length(nz)>1)
660                nz <- reduce(nz,`|`)
661            else
662                nz <- nz[[1]]
663            parmtab[n,] <- lapply(parmtab[n,],get_rows,i=nz)
664        }
665    }
666    headers <- list()
667    if(length(modelnames) > 1 || length(modelnames) == 1 && force.header) {
668        modelnames <- do_subs(modelnames,relab.attr)
669        headers[[1]] <- Map(structure,modelnames,span=lapply(parmtab[1,],ncol))
670        if(length(modelgroups)){
671            ncols <- sapply(parmtab[1,],ncol)
672            sp <- lapply(modelgroups,function(mg)sum(ncols[mg]))
673            h <- Map(structure,names(modelgroups),span=sp)
674            headers <- c(list(h),headers)
675        }
676    }
677    # show.eqnames <- show.eqnames || has.multieq(x)
678
679    get_eq.headers <- function(x){
680        cf <- x$coef
681        dn.cf <- dimnames(cf)
682        if(length(dn.cf)>2)
683            eq.names <- dimnames(cf)[[3]]
684        else
685            eq.names <- NULL
686    }
687    eq.headers <- lapply(x,get_eq.headers)
688    all.eq.names <- unique(unlist(eq.headers))
689    if(is.na(show.eqnames))
690        show.eqnames <- length(all.eq.names) > 1
691    if(!show.eqnames)
692        eq.headers <- NULL
693
694    leaders <- vector(mode="list",length=nrow(parmtab))
695    names(leaders) <- rownames(parmtab)
696    if(length(partypes)){
697      i <- 0
698      for(m in rownames(parmtab)){
699        i <- i + 1
700        pn <- parmnames[[m]]
701        pn <- do_prettyfy(pn,
702                          contrasts=contrasts,
703                          xlevels=xlevels,
704                          factor.style=factor.style,
705                          show.baselevel=show.baselevel,
706                          baselevel.sep=baselevel.sep)
707        pn <- do_subs(pn,relab.attr)
708        span <- nrow(parmtab[[m,1]])/length(pn)
709        if(span < 1)
710          leaders[[i]] <- NULL
711        else
712          leaders[[i]] <- lapply(pn,structure,span=span)
713      }
714    }
715
716    if(length(summary.stats)) {
717        sumstats <- Map(applyTemplate,sumstats,stemplates,digits=sdigits)
718        sst <- Map(getRows,sumstats,summary.stats)
719
720        snames <- unique(unlist(lapply(sst,rownames)))
721        nc <- lapply(parmtab[1,],ncol)
722        summary.stats <- Map(smryxpand,sst,list(snames))
723
724        snames <- do_subs(snames,relab.attr)
725        snames <- lapply(snames,structure,span=1)
726        leaders <- c(leaders,summary.stats=list(snames))
727    }
728    else summary.stats <- NULL
729
730    needs.signif <- any(grepl("$p",ctemplate,fixed=TRUE))
731    if(needs.signif){
732        signif.symbols <- signif.symbols
733    }
734    else
735        signif.symbols <- NULL
736
737    outtypes <- array("num",
738                      dim=dim(parmtab),
739                      dimnames=dimnames(parmtab))
740    if(length(controls)){
741        outtypes["Controls",] <- "text"
742    }
743
744    structure(list(parmtab=parmtab,
745                   leaders=leaders,
746                   headers=headers,
747                   eq.headers=eq.headers,
748                   summary.stats = summary.stats,
749                   signif.symbols=signif.symbols,
750                   controls=controls,
751                   outtypes=outtypes),
752              class="preformatted.memisc_mtable")
753    }
754
755
756format_signif <- function(syms,tmpl){
757    title <- tmpl[1]
758    clps <- tmpl[3]
759    tmpl <- tmpl[2]
760    res <- c()
761    for(i in seq_along(syms)){
762        sym <- names(syms)[i]
763        thrsh <- unname(syms[i])
764        res.i <- sub("$sym",sym,tmpl,fixed=TRUE)
765        res.i <- sub("$val",thrsh,res.i,fixed=TRUE)
766        res <- c(res,res.i)
767    }
768    res <- paste(res,collapse=clps)
769    paste0(title,res)
770}
771
772
773format.memisc_mtable <- function(x,
774                          target=c("print","LaTeX","HTML","delim"),
775                          ...){
776    target <- match.arg(target)
777    x <- preformat_mtable(x)
778    switch(target,
779           print=pf_mtable_format_print(x,...),
780           LaTeX=pf_mtable_format_latex(x,...),
781           HTML=pf_mtable_format_html(x,...),
782           delim=pf_mtable_format_delim(x,...)
783           )
784}
785
786print.memisc_mtable <- function(x,center.at=getOption("OutDec"),
787      topsep="=",bottomsep="=",sectionsep="-",...){
788
789    calls <- sapply(x,"[[","call")
790    cat("\nCalls:\n")
791    for(i in seq(calls)){
792        cat(names(calls)[i],": ",sep="")
793        print(calls[[i]])
794    }
795    cat("\n")
796    cat(format.memisc_mtable(x,target="print",
797                      center.at=center.at,
798                      topsep=topsep,
799                      bottomsep=bottomsep,
800                      sectionsep=sectionsep,...),
801        sep="")
802}
803
804toLatex.memisc_mtable <- function(object,...){
805  structure(format.memisc_mtable(x=object,target="LaTeX",...),
806  class="Latex")
807}
808
809write.mtable <- function(object,file="",
810                         format=c("delim","LaTeX","HTML"),
811                         ...){
812  l <- list(...)
813  if(isTRUE(l[["forLaTeX"]])) # Avoid breaking old code
814    target <- "LaTeX"
815  else
816    target <- match.arg(format)
817
818  f <- format.memisc_mtable(object,target=target,...)
819  if(target %in% c("LaTeX","HTML"))
820    f <- paste(f,"\n",sep="")
821  cat(f,file=file,sep="")
822}
823
824
825