Skip to content

Commit

Permalink
Add support for multiple parameter groups/types
Browse files Browse the repository at this point in the history 
Coefficients are not the only kinds of parameter. This update takes care
for variance parameters in model tables (mtables).
  • Loading branch information
@melff
melff committed May 27, 2024
1 parent 6689857 commit ac60fef
Show file tree
Hide file tree
Showing 5 changed files with 91 additions and 17 deletions.
16 changes: 16 additions & 0 deletions pkg/R/mtable-format-delim.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -35,6 +35,7 @@ pf_mtable_format_delim <- function(x,
colsep="\t",
rowsep="\n",
interaction.sep = " x ",
show.parmtypes = nrow(x$parmtab) > 1,
...
){

Expand All @@ -56,10 +57,19 @@ pf_mtable_format_delim <- function(x,

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){
Expand Down Expand Up @@ -99,6 +109,12 @@ pf_mtable_format_delim <- function(x,
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)
Expand Down
24 changes: 19 additions & 5 deletions pkg/R/mtable-format-html.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -163,6 +163,7 @@ pf_mtable_format_html <- function(x,
style=mtable_format_stdstyle,
margin="2ex auto",
sig.notes.style=c(width="inherit"),
show.parmtypes = nrow(x$parmtab) > 1,
...
){

Expand Down Expand Up @@ -231,7 +232,11 @@ pf_mtable_format_html <- function(x,
pt.ij[] <- html_td(pt.ij,vectorize=TRUE)
}
dim(pt.ij) <- dm.ij

if(show.parmtypes){
spaces <- rep(" ",ncol(pt.ij))
spaces <- html_td(spaces,vectorize=TRUE)
pt.ij <- rbind(spaces,pt.ij)
}
pt.j[[i]] <- pt.ij
}
pt.j <- do.call(rbind,pt.j)
Expand All @@ -249,7 +254,7 @@ pf_mtable_format_html <- function(x,
eq.span <- eq.span*3
eq.header.j <- html_td(eq.header.j,colspan=eq.span,vectorize=TRUE)
pt.j <- rbind(eq.header.j,pt.j)
total_hdr_lines <- max(total_hdr_lines,1+n.eq.j)
#total_hdr_lines <- max(total_hdr_lines,1+n.eq.j)
}
total_pt_lines <- max(total_pt_lines,1+nrow(pt.j))

Expand Down Expand Up @@ -278,8 +283,13 @@ pf_mtable_format_html <- function(x,
}

if(l.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)
if(has.eq.headers)
leaders <- rbind("",leaders)
Expand Down Expand Up @@ -350,14 +360,18 @@ pf_mtable_format_html <- function(x,
res <- html_table(res,id=mtable_id)

mtable_html_env$counter <- mtable_html_env$counter + 1


midrule_lines <- total_hdr_lines
midrule_lines <- c(midrule_lines,total_hdr_lines + total_pt_lines)
# browser()

style_global <- style_mtable_global(id=mtable_id,style=style,margin=margin)
style_toprule <- style_mtable_rule(id=mtable_id,rulewidth=toprule,top=TRUE,
rows=1)
style_bottomrule <- style_mtable_rule(id=mtable_id,rulewidth=bottomrule,bottom=TRUE,
rows=total_pt_lines+total_sum_lines)
style_midrule <- style_mtable_rule(id=mtable_id,rulewidth=midrule,bottom=TRUE,
rows=c(total_hdr_lines,total_pt_lines))
rows=midrule_lines)

style_content <- paste(
style_global,
Expand Down
12 changes: 11 additions & 1 deletion pkg/R/mtable-format-latex.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -59,6 +59,7 @@ pf_mtable_format_latex <- function(x,
signif.notes.spec=getOption("toLatex.signif.notes.spec",
paste0("p{",signif.notes.width,"\\linewidth}")),
signif.notes.width=getOption("toLatex.signif.notes.width",".7"),
show.parmtypes = nrow(x$parmtab) > 1,
...
){

Expand Down Expand Up @@ -107,7 +108,9 @@ pf_mtable_format_latex <- function(x,
if(useDcolumn)
pt.ij[] <- paste0("\\multicolumn{1}{c}{",pt.ij,"}")
}

if(show.parmtypes){
pt.ij <- rbind(" ",pt.ij)
}
pt.ij <- apply(pt.ij,1,paste,collapse=colsep)
pt.j[[i]] <- pt.ij
}
Expand Down Expand Up @@ -145,7 +148,14 @@ pf_mtable_format_latex <- function(x,
l.leaders <- length(leaders)
if(l.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)

leaders <- gsub(" x ",interaction.sep,leaders,fixed=TRUE)
if(escape.tex)
leaders <- LaTeXcape(leaders)
Expand Down
14 changes: 12 additions & 2 deletions pkg/R/mtable-format-print.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -76,6 +76,7 @@ pf_mtable_format_print <- function(x,
center.at=getOption("OutDec"),
align.integers=c("dot","right","left"),
padding=" ",
show.parmtypes = nrow(x$parmtab) > 1,
...
){

Expand Down Expand Up @@ -113,6 +114,9 @@ pf_mtable_format_print <- function(x,
nr.j <- numeric(l.pt.j)
for(i in 1:l.pt.j){
pt.ij <- pt.j[[i]]
if(show.parmtypes){
pt.ij <- rbind(" ",pt.ij)
}
nr.j[i] <- nrow(pt.ij)
skip.ij <- rep(FALSE,nrow(pt.ij))
tmp <- matrix("",nrow=nrow(pt.ij),ncol=maxncols.j)
Expand Down Expand Up @@ -203,11 +207,15 @@ pf_mtable_format_print <- function(x,
}
l.leaders <- length(leaders)
if(l.leaders){

leaders <- c(list(headers=rep(list(structure("",span=1)),
ld.headlines)),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)
leaders <- format(leaders,justify="left")
res <- cbind(leaders,res)
Expand All @@ -233,6 +241,8 @@ pf_mtable_format_print <- function(x,
sectseps <- c(sectseps, sectionrule)
sectsep.at <- c(sectsep.at, csum)
csum <- csum + nrow(pt[[i,1]])
if(show.parmtypes)
csum <- csum + 1
}
if(length(sst) && any(sapply(sst,length)>0)){
sectseps <- c(sectseps, sectionrule)
Expand Down
42 changes: 33 additions & 9 deletions pkg/R/mtable.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -264,8 +264,10 @@ mtable <- function(...,
else
summaries <- lapply(args,getSummary)

parameter.types <- unique(unlist(lapply(summaries,names)))
parameter.types <- parameter.types[parameter.types %nin% c("sumstat","contrasts","call","xlevels")]
# parameter.types <- unique(unlist(lapply(summaries,names)))
# parameter.types <- parameter.types[parameter.types %nin% c("sumstat","contrasts","call","xlevels")]
parameter.types <- unique(unlist(lapply(summaries,`[[`,"parameter.types")))
parameter.types <- c("coef",parameter.types)
parmnames <- list()
for(pt in parameter.types){

Expand Down Expand Up @@ -514,12 +516,15 @@ dropnull <- function(x) {
x[!ii]
}
ni <- function(tab,x) x%in%tab
drop_zchrow <- function(x)x[nzchar_row(x),,drop=FALSE]

preformat_mtable <- function(x){

x <- unclass(x)

coef.style <- attr(x,"coef.style")
summary.stats <- attr(x,"summary.stats")
other.stats <- attr(x,"other.stats")
signif.symbols <- attr(x,"signif.symbols")
factor.style <- attr(x,"factor.style")
show.baselevel <- attr(x,"show.baselevel")
Expand All @@ -529,17 +534,21 @@ preformat_mtable <- function(x){
stemplates <- attr(x,"stemplates")
sdigits <- attr(x,"sdigits")

allcompo <- unique(unlist(lapply(x,names)))
nonparnames <- c("sumstat","contrasts","xlevels","call")
partypes <- setdiff(allcompo,nonparnames)
# allcompo <- unique(unlist(lapply(x,names)))
# nonparnames <- c("sumstat","contrasts","xlevels","call")
# partypes <- setdiff(allcompo,nonparnames)

sumstats <- lapply(x,`[[`,"sumstat")
contrasts <- lapply(x,`[[`,"contrasts")
xlevels <- lapply(x,`[[`,"xlevels")
calls <- lapply(x,`[[`,"call")

partypes <- unique(c("coef",unlist(lapply(x,`[[`,"parameter.types"))))
parms <- lapply(x,`[`,partypes)
parms <- lapply(parms,dropnull)

descriptives <- lapply(x,`[[`,"descriptives")

ctemplate <- getCoefTemplate(coef.style)
if(!length(ctemplate)) stop("invalid coef.style argument")
ctemplate <- as.matrix(ctemplate)
Expand Down Expand Up @@ -713,10 +722,10 @@ preformat_mtable <- function(x){
}
}

if(length(summary.stats)) {
sumstats <- Map(applyTemplate,sumstats,stemplates,digits=sdigits)
sst <- Map(getRows,sumstats,summary.stats)

if(length(summary.stats)){
stemplates_ <- Map(select_by_names,stemplates,summary.stats)
sst <- Map(applyTemplate,sumstats,stemplates_,digits=sdigits)
sst <- lapply(sst,drop_zchrow)
snames <- unique(unlist(lapply(sst,rownames)))
nc <- lapply(parmtab[1,],ncol)
summary.stats <- Map(smryxpand,sst,list(snames))
Expand All @@ -727,6 +736,13 @@ preformat_mtable <- function(x){
}
else summary.stats <- NULL

if(length(descriptives)){
dnames <- unique(unlist(lapply(descriptives,rownames)))
nc <- lapply(parmtab[1,],ncol)
descriptives <- Map(smryxpand,descriptives,list(dnames))
}
else descriptives <- NULL

needs.signif <- any(grepl("$p",ctemplate,fixed=TRUE))
if(needs.signif){
signif.symbols <- signif.symbols
Expand All @@ -746,12 +762,20 @@ preformat_mtable <- function(x){
headers=headers,
eq.headers=eq.headers,
summary.stats = summary.stats,
other.stats = other.stats,
signif.symbols=signif.symbols,
controls=controls,
outtypes=outtypes),
class="preformatted.memisc_mtable")
}

# Avoid NA's while subsetting
select_by_names <- function(x,nms){
nms <- unique(nms)
nms <- intersect(names(x),nms)
x[nms]
}


format_signif <- function(syms,tmpl){
title <- tmpl[1]
Expand Down

0 comments on commit ac60fef

Please sign in to comment.