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