Nothing
R/modelsSummary.R
In processR: Implementation of the 'PROCESS' Macro
Defines functions
getInfo
pformat
myformat
modelsSummaryTable
numberSubscript
centerPrint
print.modelSummary
modelsSummary
makeCoefLabel
Documented in
centerPrint
getInfo
makeCoefLabel
modelsSummary
modelsSummaryTable
myformat
numberSubscript
pformat
print.modelSummary
#' Change regression coefficient name
#' @param name string vector to change
#' @param dep names of dependent variable
#' @param labels optional list
#' @param constant name of constant
#' @param prefix name of prefix
#' @export
makeCoefLabel=function(name,dep,labels,constant,prefix){
# name=c("(Intercept)","negtone","negexp","dysfunc","negtone:negexp")
# name=c("(Intercept)","dysfunc")
# dep="perform"
# labels=list(X="dysfunc",M="negtone",W="negexp",Y="perform")
# constant="iy"
# prefix="c"
# labels=list(X="protest",W="sexism",M="respappr",Y="liking")
# dep="respappr"
# name=c("D1","D2","sexism")
# constant="iy"
# prefix="c"
# name=c("(Intercept)","cond","import")
# dep="pmi"
# labels=list(X="cond",M=c("import","pmi"),Y="reaction")
# name=c("X","M1","M2")
# dep="M3"
# labels=list(X="X",M=c("M1","M2","M3"),Y="Y")
# cat("name=",name,"\n")
# name=c("M","X","M:W","W","X:W")
# dep="Y"
# labels=list(X="X",M="M",Y="Y")
# constant="iy"
# prefix="b"
# name=c("baby","milk","baby:milk")
# prefix="a"
# dep="wine";constant="iy"
# labels=list(X="baby",M=c("wine","tent","sand"),Y="tile",W="milk")
result=c()
dep=changeLabelName(dep,labels,add=FALSE)
dep
# cat("dep=",dep,"\n")
j<-k<-l<-m<-1
# if((substr(dep,1,1)=="M")&(nchar(dep)==2)){
# j=as.numeric(paste0(substr(dep,2,2),"1"))
# }
temp=changeLabelName(name,labels,add=FALSE)
# cat("temp=",temp,"\n")
for(i in seq_along(temp)){
if(stringr::str_detect(temp[i],"D[1-9]")){
temp[i]=stringr::str_replace(temp[i],"D","X")
}
}
for(i in seq_along(temp)){
if(dep=="Y"){
if(temp[i]=="(Intercept)"){
result=c(result,"iY")
} else if(str_detect(temp[i],"^X[1-9]?")){
result=c(result,paste0("c",j))
j=j+1
} else if(str_detect(temp[i],"^C[1-9]?")){
if(nchar(temp[i])==1){
result=c(result,paste0("g"))
} else{
result=c(result,paste0("g",substr(temp[i],2,2)))
}
} else if(str_detect(temp[i],"^(W|V|Z)[1-9]?")){
if(paste0("X:",temp[i]) %in% temp){
result=c(result,paste0("c",j))
j=j+1
} else if(any(str_detect(temp,paste0("X[1-9]?:")))){
result=c(result,paste0("c",j))
j=j+1
} else{
result=c(result,paste0("b",l))
l=l+1
}
} else if(str_detect(temp[i],":X[1-9]?")){
result=c(result,paste0("c",j))
j=j+1
} else{
result=c(result,paste0("b",l))
l=l+1
}
} else if(dep=="M"){
if(temp[i]=="(Intercept)"){
result=c(result,"iM")
} else if(str_detect(temp[i],"^C[1-9]?")){
if(nchar(temp[i])==1){
result=c(result,"f")
} else{
result=c(result,paste0("f",substr(temp[i],2,2)))
}
} else{
result=c(result,paste0("a",j))
j=j+1
}
} else{ ## "M1","M2",...
if(temp[i]=="(Intercept)"){
result=c(result,paste0("i",dep))
} else if(str_detect(temp[i],"^C[1-9]?")){
result=c(result,paste0("f",k,substr(dep,2,2)))
k=k+1
} else if(str_detect(temp[i],"^M[1:9]?")){
if(nchar(temp[i])==2){ # M1
result=c(result,paste0("d",substr(dep,2,2),substr(temp[i],2,2)))
} else{ ## M1:W
result=c(result,paste0("d",substr(dep,2,2),substr(temp[i],2,2),l))
l<-l+1
}
} else if(str_detect(temp[i],"^(W|V|Z)[1-9]?")){
if(paste0("X:",temp[i]) %in% temp){
result=c(result,paste0("a",j,substr(dep,2,2)))
j=j+1
} else{
tempvar=temp[str_detect(temp,"^M[1-9]:")][1]
result=c(result,paste0("d",substr(dep,2,2),substr(tempvar,2,2),l))
# result=c(result,paste0(prefix,l))
l<-l+1
# result=c(result,paste0("b",l))
# l=l+1
}
} else{
result=c(result,paste0("a",substr(dep,2,2)))
# if(length(temp)==1){
# result=c(result,paste0("a",substr(dep,2,2)))
# } else{
# result=c(result,paste0("a",j,substr(dep,2,2)))
# j=j+1
# }
}
}
# if(temp[i]=="(Intercept)") {
# if(dep=="M1") {
# result=c(result,"iM1")
# } else if(dep=="M2"){
# result=c(result,"iM2")
# } else {
# result=c(result,constant)
# }
# } else if(temp[i]=="M") {
# result=c(result,paste0("b",l))
# l=l+1
# } else if(substr(temp[i],1,1)=="C"){
# if(dep=="Y") {
# result=c(result,paste0("g",k))
# } else{
# result=c(result,paste0("f",k))
#
# }
# k<-k+1
# } else if(temp[i]=="X"){
# if(dep=="Y") {
# result=c(result,paste0(ifelse(any(str_detect(temp,"^M")),"c'","c"),j))
#
# } else if(str_detect(dep,"^M")){
# result=c(result,paste0("a",j))
# } else{
# result=c(result,paste0(prefix,j))
#
# }
# j<-j+1
# } else if(temp[i]=="W"){
# if(("X:W" %in% temp)|("W:X" %in% temp)|("D1:W" %in% temp)|("W:D1" %in% temp)){
# if(dep=="Y") {
# result=c(result,paste0(ifelse(any(str_detect(temp,"^M")),"c'","c"),j))
#
# } else{
# result=c(result,paste0(prefix,j))
#
# }
# j<-j+1
# } else if(dep %in% c(paste0("M",2:9))) {
# tempvar=temp[str_detect(temp,"^M[1-9]:")][1]
# temp1=paste0("d",substr(dep,2,2),substr(tempvar,2,2))
# if(m>1) temp1=paste0(temp1,m)
# result=c(result,temp1)
# m<-m+1
# } else{
# # result=c(result,paste0("b",l))
# # l<-l+1
# if(any(str_detect(temp,"^M[1-9]:"))){
# # tempvar=temp[str_detect(temp,"^M[1-9]:")][1]
# # cat("tempvar=",tempvar,"\n")
# # result=c(result,paste0(prefix,substr(tempvar,2,2),l))
# result=c(result,paste0(prefix,l))
# l<-l+1
# } else{
# result=c(result,paste0(prefix,j))
# l<-l+1
# }
#
# }
#
# } else if(temp[i] %in% c("X:W","W:X")){
# if(dep=="Y") {
# result=c(result,paste0(ifelse(any(str_detect(temp,"^M")),"c'","c"),j))
#
# } else{
# result=c(result,paste0(prefix,j))
#
# }
# j<-j+1
#
#
# } else if(str_detect(temp[i],"^D[0-9]")){
# if(dep=="Y") {
# result=c(result,paste0(ifelse("M" %in% temp,"c'","c"),j))
#
# } else{
# result=c(result,paste0(prefix,j))
#
# }
# j<-j+1
#
#
# } else if(str_detect(temp[i],"^M[1-9]:?")){
#
# if(dep %in% c(paste0("M",2:9))) {
# temp1=paste0("d",substr(dep,2,2),substr(temp[i],2,2))
# if(m>1) temp1=paste0(temp1,m)
# result=c(result,temp1)
# m<-m+1
# } else{
# # result=c(result,paste0("b",substr(temp[i],2,2),l))
# result=c(result,paste0("b",l))
# l=l+1
# }
# } else { #if(temp[i]=="M:W")
# result=c(result,paste0("b",l))
# l=l+1
#
# }
}
if(any(str_detect(result,"b"))){
result=str_replace(result,"c","c'")
}
result
if(!("c2" %in% result)) result[result=="c1"]="c"
if(!("c'2" %in% result)) result[result=="c'1"]="c'"
if(!("b2" %in% result)) result[result=="b1"]="b"
if(!dep %in% c("M1","M2","M3")){
if(!("a2" %in% result)) result[result=="a1"]="a"
}
if(!("f2" %in% result)) result[result=="f1"]="f"
if(!("g2" %in% result)) result[result=="g1"]="g"
if("W:X" %in% temp) {
result[result=="c'1"]="c'4"
result[result=="c'2"]="c'1"
result[result=="c'4"]="c'2"
}
# cat("result=",result,"\n")
result
}
#' Make Summary for Model Coefficients
#' @param fit A list of objects of class lm
#' @param labels optional list
#' @param vars optional list
#' @param moderator optional list
#' @param covar optional list
#' @param serial logical
#' @param data optional data.frame
#' @param prefix A character
#' @param constant A string vector
#' @param autoPrefix logical automatic numbering of prefix
#' @importFrom dplyr full_join
#' @importFrom purrr reduce
#' @importFrom stringr "%>%"
#' @importFrom tidyselect starts_with
#' @export
#' @return A data.frame
#' @examples
#' fit1=lm(mpg~wt,data=mtcars)
#' fit2=lm(mpg~wt*hp*am,data=mtcars)
#' fit=list(fit1,fit2)
#' labels=list(Y="mpg",X="wt",W="hp",Z="am")
#' modelsSummary(fit,labels=labels)
#' labels=list(Y="withdraw",M="affect",X="estress")
#' covar=list(name=c("ese","sex","age"),site=list(c("M","Y"),c("M","Y"),c("M","Y")))
#' modelsSummary(labels=labels,covar=covar,data=estress)
#' labels=list(X="dysfunc",M="negtone",W="negexp",Y="perform")
#' moderator=list(name="negexp",site=list(c("a","b","c")))
#' eq=tripleEquation(labels=labels,moderator=moderator,data=teams,mode=1)
#' fit=eq2fit(eq,data=teams)
#' modelsSummary(fit,labels=labels)
#' labels=list(X="cond",M="pmi",Y="reaction")
#' modelsSummary(labels=labels,data=pmi)
modelsSummary=function(fit=NULL,labels=NULL,vars=NULL,moderator=NULL,covar=NULL,serial=FALSE,data=NULL,prefix="b",constant="iy",autoPrefix=TRUE){
# prefix="b";constant="iy";autoPrefix=TRUE
if(!is.null(covar)){
for(i in seq_along(covar$name)){
labels[[paste0("C",i)]]=covar$name[i]
}
}
if(length(vars)>0){
if(is.null(vars$label)){
if(length(vars$name)==1){
labels[["W"]]=vars$name[[1]][1]
labels[["Z"]]=vars$name[[1]][2]
} else{
for(i in seq_along(vars$name)){
labels[[paste0("W",i)]]=vars$name[[i]][1]
labels[[paste0("Z",i)]]=vars$name[[i]][2]
}
}
} else{
if(length(vars$name)==1){
labels[[vars$label[[1]][1]]]=vars$name[[1]][1]
labels[[vars$label[[1]][2]]]=vars$name[[1]][2]
} else{
for(i in seq_along(vars$name)){
labels[[vars$label[[i]][1]]]=vars$name[[i]][1]
labels[[vars$label[[i]][2]]]=vars$name[[i]][2]
}
}
}
}
if(length(moderator)>0){
if(is.null(moderator$label)){
prefix=ifelse(length(vars)==0,"W","V")
if(length(moderator$name)==1){
labels[[prefix]]=moderator$name
} else{
for(i in 1:length(moderator$name)){
labels[[paste0(prefix,i)]]=moderator$name[i]
}
}
} else{
for(i in 1:length(moderator$label)){
labels[[moderator$label[i]]]=moderator$name[i]
}
}
}
if(is.null(fit)){
#eq=tripleEquation(labels=labels,vars=vars,moderator=moderator,covar=covar,data=data,mode=1)
eq=multipleMediation(labels=labels,vars=vars,moderator=moderator,covar=covar,serial=serial,data=data,mode=1)
fit=eq2fit(eq,data=data)
}
if("lm" %in% class(fit)) fit=list(fit)
count=length(fit)
df<-coef<-list()
modelNames=c()
if(length(constant)==1) constant=rep(constant,count)
if(length(prefix)==1) prefix=rep(prefix,count)
for(i in 1 :count){
df[[i]]=data.frame(summary(fit[[i]])$coef)
colnames(df[[i]])=paste0(c("coef","se","t","p"),i)
df[[i]][["name1"]]=rownames(df[[i]])
if(autoPrefix &(!is.null(labels))) {
temp=names(fit[[i]]$model)[1]
temp1=changeLabelName(temp,labels,add=FALSE)
if(temp1=="M") {
constant[i]="im"
prefix[i]="a"
} else if(temp1=="Y"){
constant[i]="iy"
prefix[i]="c"
temp2=changeLabelName(rownames(df[[i]]),labels,add=FALSE)
if("M" %in% temp2){
prefix[i]="c'"
}
}
}
df
if(autoPrefix &(!is.null(labels))) {
df[[i]][[paste0("label",i)]]=makeCoefLabel(rownames(df[[i]]),dep=names(fit[[i]]$model)[1],labels,constant[i],prefix[i])
} else{
df[[i]][[paste0("label",i)]]=c(constant[i],paste0(prefix[i],1:(nrow(df[[i]])-1)))
}
colnames(df[[i]])[5]="name1"
coef[[i]]=getInfo(fit[[i]])[1:5]
df[[i]]<-df[[i]] %>% select(starts_with("label"),everything())
modelNames=c(modelNames,names(fit[[i]]$model)[1])
}
if(!is.null(labels)) modelNames=changeLabelName(modelNames,labels,add=TRUE)
df
if(count==1){
mydf=df[[1]]
} else{
mydf<-reduce(df,full_join,by="name1")
}
mydf
mydf<-mydf %>% select("name1",everything())
rownames(mydf)=mydf[["name1"]]
mydf<-mydf[-1]
mydf[]=lapply(mydf,myformat)
mydf<-mydf[c(2:nrow(mydf),1),]
rownames(mydf)[nrow(mydf)]="Constant"
mydf
for(i in 1:count){
mydf[[5*i]]=pformat(mydf[[5*i]])
}
finalNames=rownames(mydf)
df2=data.frame(coef,stringsAsFactors = FALSE)
colnames(df2)=paste0("coef",1:ncol(df2))
finalNames=c(finalNames,c("Observations","R2","Adjusted R2","Residual SE","F statistic"))
res=full_join(mydf,df2,by=paste0("coef",1:count))
res[is.na(res)]=""
res
if(!is.null(labels)) finalNames=changeLabelName(finalNames,labels,add=TRUE)
rownames(res)=finalNames
res
class(res)=c("modelSummary","data.frame")
attr(res,"modelNames")=modelNames
res
}
#'S3 method print for object modelSummary
#'@param x Object of class modelSummary
#'@param ... additional arguments to pass to print.modelSummary
#'@importFrom stringr str_pad
#'@export
print.modelSummary=function(x,...){
count=ncol(x)/5
colwidth=37
left=25
total=left+colwidth*count+1
right=colwidth*count+1
cat(paste(rep("=",total),collapse = ""),"\n")
cat(paste0(centerPrint("",left),centerPrint("Consequent",right)),"\n")
cat(paste0(centerPrint("",left),paste(rep("-",right),collapse = "")),"\n")
names=attr(x,"modelNames")
cat(paste0(centerPrint("",left)))
for(i in 1:count){cat(centerPrint(names[i],colwidth))}
cat("\n")
cat(paste0(centerPrint("",left)))
for(i in 1:count) cat(paste0(rep("-",colwidth),collapse = "")," ")
cat("\n")
cat(paste0(centerPrint("Antecedent",left)))
for(i in 1:count) cat(paste0(centerPrint("",5),centerPrint("Coef",8),centerPrint("SE",8),centerPrint("t",8),centerPrint("p",8)," "))
cat("\n")
cat(paste(rep("-",total),collapse = ""),"\n")
for(i in 1:(nrow(x)-5)){
cat(centerPrint(rownames(x)[i],left))
for(j in 1:count){
for(k in 1:5){
if(k==1){
cat(str_pad(x[i,(j-1)*5+k],3,"left")," ")
} else{
cat(str_pad(x[i,(j-1)*5+k],6,"left")," ")
}
cat(ifelse((j==count)&(k==5),"\n",""))
}
}
}
cat(paste(rep("-",total),collapse = ""),"\n")
for(i in (nrow(x)-4):nrow(x)){
cat(centerPrint(rownames(x)[i],left))
for(j in 1:count){
cat(centerPrint(x[i,(j-1)*5+2],colwidth))
cat(ifelse(j==count,"\n",""))
}
}
cat(paste(rep("=",total),collapse = ""),"\n")
}
#' Print a string in center
#' @param string A string
#' @param width A numeric
#' @export
centerPrint=function(string,width){
str_pad(string,width,side="both")
}
#'Make number subscript
#'@param ft An object of class flextable
#'@param label string vector
#'@param vanilla logical
#'@importFrom officer fp_text
#'@importFrom flextable mk_par as_paragraph as_i as_sub
#'@importFrom stringr str_extract
numberSubscript=function(ft,label,vanilla){
add=ifelse(vanilla,1,0)
for(i in seq_along(label)){
temp=paste0("mk_par(ft,j=",(i-1)*(5+add)+2,
",value=as_paragraph(
as_i(stringr::str_extract(",label[i],",'[^0-9yYmM]*')),
as_i(as_sub(stringr::str_extract(",label[i],",'[0-9yYmM].*')))),
part='body')")
ft<-eval(parse(text=temp))
}
ft
}
#' Make Summary Table for Model Coefficients
#' @param x An object of class modelSummary
#' @param vanilla A logical
#' @param ... further arguments to be passed to modelsSummary()
#' @importFrom officer fp_border
#' @importFrom flextable flextable merge_h_range align hline_top hline add_header
#' @importFrom flextable bold fontsize width italic set_header_labels add_header_row
#' @importFrom flextable theme_zebra vline_left
#' @importFrom stats pf
#' @importFrom dplyr select
#' @importFrom tidyselect everything
#' @importFrom stats setNames
#' @export
#' @return A flextable
#' @examples
#' \donttest{
#' fit1=lm(mpg~wt,data=mtcars)
#' fit2=lm(mpg~wt*hp,data=mtcars)
#' fit3=lm(mpg~wt*hp*am,data=mtcars)
#' labels=list(X="wt",W="hp",Y="mpg",Z="am")
#' x=modelsSummary(fit1,labels=labels)
#' modelsSummaryTable(x)
#' modelsSummaryTable(x,vanilla=FALSE)
#' x=modelsSummary(list(fit1,fit2),labels=labels)
#' modelsSummaryTable(x)
#' modelsSummaryTable(x,vanilla=FALSE)
#' x=modelsSummary(list(fit1,fit2,fit3),labels=labels)
#' modelsSummaryTable(x)
#' modelsSummaryTable(x,vanilla=FALSE)
#'}
modelsSummaryTable=function(x=NULL,vanilla=TRUE,...){
# vanilla=TRUE
# require(tidyverse)
# require(flextable)
# require(officer)
# fit1=lm(mpg~wt,data=mtcars)
# fit2=lm(mpg~wt*hp,data=mtcars)
# labels=list(X="wt",W="hp",Y="mpg",Z="am")
# x=modelsSummary(list(fit1,fit2))
if(is.null(x)) {
x=modelsSummary(...)
}
if(!("modelSummary" %in% class(x))) {
x=modelsSummary(x,...)
}
x[x=="im"]="iM"
x[x=="iy"]="iY"
modelNames=attr(x,"modelNames")
modelNames
result=x
count=ncol(x)/5
count
result[["name1"]]=rownames(result)
if(vanilla){
if(count>1){
for(i in 2:count) result[[paste0("s",(i-1))]]=""
}
}
result<-result %>% select("name1",everything())
rowcount=nrow(result)
if(vanilla) {
col_keys=c("name1",names(result)[2:6])
if(count>1){
for(i in 1:(count-1)) {
col_keys=c(col_keys,paste0("s",i),names(result)[(i*5+2):(i*5+6)])
}
}
} else{
col_keys=names(result)
}
ft<-flextable(result,col_keys=col_keys)
ft
hlabel=c("Antecedent","","Coef","SE","t","p")
if(count>1){
for(i in 2:count){
if(vanilla) { hlabel=c(hlabel,"","","Coef","SE","t","p") }
else { hlabel=c(hlabel,"","Coef","SE","t","p") }
}
}
hlabel<-setNames(hlabel,col_keys)
hlabel=as.list(hlabel)
hlabel
ft<-ft %>% set_header_labels(values=hlabel)
colcount=5+ifelse(vanilla,1,0)
ft
for(i in 1:count){
ft<- ft %>% merge_h_range(i=(rowcount-4):rowcount,
j1=colcount*(i-1)+3,j2=colcount*(i-1)+6)
}
ft<- ft %>% align(align="center",part="all") %>%
hline_top(part="header",border=fp_border(color="white",width=0))
ft
for(i in 1:count){
ft <- ft %>% hline_top(j=((i-1)*colcount+2):(i*colcount),
part="header",border=fp_border(color="black",width=1))
}
big_border=fp_border(color="black",width=2)
hlabel=c("","",modelNames[1],rep("",3))
if(count>1){
for(i in 2:count){
if(vanilla) {hlabel=c(hlabel,"","",modelNames[i],rep("",3))}
else {hlabel=c(hlabel,"",modelNames[i],rep("",3))}
}
}
hlabel<-setNames(hlabel,col_keys)
hlabel=as.list(hlabel)
hlabel
length(hlabel)
length(col_keys)
count
colcount
ft
ft <- add_header_row(ft,values=hlabel,top=TRUE,
colwidths=rep(1,count*colcount+ifelse(vanilla,0,1)))
ft <- ft %>%
hline_top(j=2:(count*colcount++ifelse(vanilla,0,1)),part="header",border=fp_border(color="black",width=1))
ft
for(i in 1:count){
ft<-ft %>% hline(i=1,j=((i-1)*colcount+3):((i-1)*colcount+6),
part="header",border=fp_border(color="black",width=1))
}
for(i in 1:count){
ft <- ft %>% merge_h_range (i=1,j1=(i-1)*colcount+3,j2=(i-1)*colcount+6,
part="header")
}
ft
hlabel=list(name1="",coef1="Consequent")
ft<-ft %>%
add_header_row(top=TRUE,values=hlabel,
colwidths=c(1,count*colcount+ifelse(vanilla,0,1)-1)) %>%
hline_top(part="header",border=big_border) %>%
hline(i=1,j=2:(count*colcount+ifelse(vanilla,0,1)),part="header",
border=fp_border(color="black",width=1)) %>%
merge_h_range(i=1,j1=2,j2=count*colcount+ifelse(vanilla,0,1),part="header") %>%
align(align="center",part="header") %>%
align(align="right",part="body") %>%
bold(part="header") %>%
align(i=(nrow(x)-4):nrow(x),align="center",part="body") %>%
fontsize(part="all",size=12) %>%
hline(i=rowcount-5,border=fp_border(color="gray"),part="body")
ft
if(count>1){
if(vanilla) {
for(i in 1:(count-1)){
ft<-ft %>% width(j=i*6+1,width=0.001)
}
for(i in 1:count){
ft<-ft %>% width(j=(i-1)*6+2,width=0.4)
}
} else{
for(i in 1:count){
ft<-ft %>% width(j=(i-1)*5+2,width=0.4)
}
}
for(i in 1:(count)){
ft<-ft %>% italic(i=3,j=c(((i-1)*colcount+3):((i-1)*colcount+5)),
italic=TRUE,part="header")
}
} else{
ft<-ft %>% width(j=2,width=0.4)
}
ft
if(!vanilla){
ft <-ft %>%
theme_zebra(even_body="#EFEFEF",odd_body="transparent",
even_header ="#5B7778",odd_header="#5B7778") %>%
fontsize(size=12,part="all") %>%
align(align="center",part="header") %>%
align(j=1,align="center",part="body") %>%
align(j=2:(1+colcount*count),align="right",part="body") %>%
align(i=(nrow(x)-4):nrow(x),align="center",part="body") %>%
color(color="white",part="header") %>%
hline(j=2:(1+colcount*count),border=fp_border(color="black",width=1),
part="header") %>%
vline(j=1:(1+colcount*count),border=fp_border(color="black",width=1),
part="header") %>%
vline_left(border=fp_border(color="black",width=1),
part="header") %>%
hline(j=1:(1+colcount*count),border=fp_border(color="#EDBD3E",width=1),
part="body") %>%
vline(j=1:(1+colcount*count),border=fp_border(color="#EDBD3E",width=1),
part="body") %>%
vline_left(border=fp_border(color="#EDBD3E",width=1),
part="body")
}
ft
count=ncol(x)/5
label=paste0("label",1:count)
ft<-ft %>% numberSubscript(label=label,vanilla=vanilla) %>%
align(align="center",j=label,part="body")
ft<-ft %>% width(j=1,width=0.3) %>%
align(align="center",j=1,part="body")
if(vanilla) {
ft<- ft %>% width(j=2:((count-1)*6+2),width=1.1) %>%
width(j=1,width=0.3)
if(count>1) {
for(i in 1:(count-1)){
ft<-ft %>% width(j=i*6+1,width=0.001)
}
}
} else{
ft<- ft %>% width(j=2:((count-1)*5+2),width=1.1) %>%
width(j=1,width=0.3)
}
ft
}
#'Format a numeric vector
#'@param x A numeric vector
#'@param digits integer indicating the number of decimal places
#'@export
myformat=function(x,digits=3){
if(is.numeric(x)){
fmt=paste0("%.0",digits,"f")
x=sprintf(fmt,x)
}
x[x=="NA"]<-""
x
}
#' Make p value format
#'@param x A numeric vector
#'@export
pformat=function(x){
temp=substr(x,2,nchar(x))
temp[temp==".000"]="<.001"
temp
}
#'Get information of a model
#' @param fit object of class lm
#' @param digits integer indicating the number of decimal places
#' @export
#' @examples
#' fit=lm(mpg~wt*hp,data=mtcars)
#' getInfo(fit)
getInfo=function(fit,digits=3){
fmt=paste0("%.0",digits,"f")
r1=nrow(fit$model)
x<-summary(fit)
r2=sprintf(fmt,x$r.squared)
r3=sprintf(fmt,x$adj.r.squared)
r4=paste0(sprintf(fmt,x$sigma)," ( df = ",round(x$df[2]),")")
f=paste0("F(",round(x$fstatistic[2]),",",round(x$fstatistic[3]),") = ",
sprintf(fmt,x$fstatistic[1]))
p=sprintf(paste0("%0.",digits,"f"),pf(x$fstatistic[1L],
x$fstatistic[2L], x$fstatistic[3L], lower.tail = FALSE))
p
p=substr(p,2,digits+2)
if(p==".000") p="< .001"
else p=paste0("= ",p)
f=paste0(f,", p ",p)
MSE=sprintf(paste0("%0.",digits,"f"),sum(fit$residuals^2)/(r1-x$fstatistic[2]-1))
result=c(r1,r2,r3,r4,f,MSE)
result
}
Try the processR package in your browser
Any scripts or data that you put into this service are public.
processR documentation built on Jan. 23, 2023, 5:44 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions getInfo pformat myformat modelsSummaryTable numberSubscript centerPrint print.modelSummary modelsSummary makeCoefLabel
Documented in centerPrint getInfo makeCoefLabel modelsSummary modelsSummaryTable myformat numberSubscript pformat print.modelSummary
#' Change regression coefficient name
#' @param name string vector to change
#' @param dep names of dependent variable
#' @param labels optional list
#' @param constant name of constant
#' @param prefix name of prefix
#' @export
makeCoefLabel=function(name,dep,labels,constant,prefix){
# name=c("(Intercept)","negtone","negexp","dysfunc","negtone:negexp")
# name=c("(Intercept)","dysfunc")
# dep="perform"
# labels=list(X="dysfunc",M="negtone",W="negexp",Y="perform")
# constant="iy"
# prefix="c"
# labels=list(X="protest",W="sexism",M="respappr",Y="liking")
# dep="respappr"
# name=c("D1","D2","sexism")
# constant="iy"
# prefix="c"
# name=c("(Intercept)","cond","import")
# dep="pmi"
# labels=list(X="cond",M=c("import","pmi"),Y="reaction")
# name=c("X","M1","M2")
# dep="M3"
# labels=list(X="X",M=c("M1","M2","M3"),Y="Y")
# cat("name=",name,"\n")
# name=c("M","X","M:W","W","X:W")
# dep="Y"
# labels=list(X="X",M="M",Y="Y")
# constant="iy"
# prefix="b"
# name=c("baby","milk","baby:milk")
# prefix="a"
# dep="wine";constant="iy"
# labels=list(X="baby",M=c("wine","tent","sand"),Y="tile",W="milk")
result=c()
dep=changeLabelName(dep,labels,add=FALSE)
dep
# cat("dep=",dep,"\n")
j<-k<-l<-m<-1
# if((substr(dep,1,1)=="M")&(nchar(dep)==2)){
# j=as.numeric(paste0(substr(dep,2,2),"1"))
# }
temp=changeLabelName(name,labels,add=FALSE)
# cat("temp=",temp,"\n")
for(i in seq_along(temp)){
if(stringr::str_detect(temp[i],"D[1-9]")){
temp[i]=stringr::str_replace(temp[i],"D","X")
}
}
for(i in seq_along(temp)){
if(dep=="Y"){
if(temp[i]=="(Intercept)"){
result=c(result,"iY")
} else if(str_detect(temp[i],"^X[1-9]?")){
result=c(result,paste0("c",j))
j=j+1
} else if(str_detect(temp[i],"^C[1-9]?")){
if(nchar(temp[i])==1){
result=c(result,paste0("g"))
} else{
result=c(result,paste0("g",substr(temp[i],2,2)))
}
} else if(str_detect(temp[i],"^(W|V|Z)[1-9]?")){
if(paste0("X:",temp[i]) %in% temp){
result=c(result,paste0("c",j))
j=j+1
} else if(any(str_detect(temp,paste0("X[1-9]?:")))){
result=c(result,paste0("c",j))
j=j+1
} else{
result=c(result,paste0("b",l))
l=l+1
}
} else if(str_detect(temp[i],":X[1-9]?")){
result=c(result,paste0("c",j))
j=j+1
} else{
result=c(result,paste0("b",l))
l=l+1
}
} else if(dep=="M"){
if(temp[i]=="(Intercept)"){
result=c(result,"iM")
} else if(str_detect(temp[i],"^C[1-9]?")){
if(nchar(temp[i])==1){
result=c(result,"f")
} else{
result=c(result,paste0("f",substr(temp[i],2,2)))
}
} else{
result=c(result,paste0("a",j))
j=j+1
}
} else{ ## "M1","M2",...
if(temp[i]=="(Intercept)"){
result=c(result,paste0("i",dep))
} else if(str_detect(temp[i],"^C[1-9]?")){
result=c(result,paste0("f",k,substr(dep,2,2)))
k=k+1
} else if(str_detect(temp[i],"^M[1:9]?")){
if(nchar(temp[i])==2){ # M1
result=c(result,paste0("d",substr(dep,2,2),substr(temp[i],2,2)))
} else{ ## M1:W
result=c(result,paste0("d",substr(dep,2,2),substr(temp[i],2,2),l))
l<-l+1
}
} else if(str_detect(temp[i],"^(W|V|Z)[1-9]?")){
if(paste0("X:",temp[i]) %in% temp){
result=c(result,paste0("a",j,substr(dep,2,2)))
j=j+1
} else{
tempvar=temp[str_detect(temp,"^M[1-9]:")][1]
result=c(result,paste0("d",substr(dep,2,2),substr(tempvar,2,2),l))
# result=c(result,paste0(prefix,l))
l<-l+1
# result=c(result,paste0("b",l))
# l=l+1
}
} else{
result=c(result,paste0("a",substr(dep,2,2)))
# if(length(temp)==1){
# result=c(result,paste0("a",substr(dep,2,2)))
# } else{
# result=c(result,paste0("a",j,substr(dep,2,2)))
# j=j+1
# }
}
}
# if(temp[i]=="(Intercept)") {
# if(dep=="M1") {
# result=c(result,"iM1")
# } else if(dep=="M2"){
# result=c(result,"iM2")
# } else {
# result=c(result,constant)
# }
# } else if(temp[i]=="M") {
# result=c(result,paste0("b",l))
# l=l+1
# } else if(substr(temp[i],1,1)=="C"){
# if(dep=="Y") {
# result=c(result,paste0("g",k))
# } else{
# result=c(result,paste0("f",k))
#
# }
# k<-k+1
# } else if(temp[i]=="X"){
# if(dep=="Y") {
# result=c(result,paste0(ifelse(any(str_detect(temp,"^M")),"c'","c"),j))
#
# } else if(str_detect(dep,"^M")){
# result=c(result,paste0("a",j))
# } else{
# result=c(result,paste0(prefix,j))
#
# }
# j<-j+1
# } else if(temp[i]=="W"){
# if(("X:W" %in% temp)|("W:X" %in% temp)|("D1:W" %in% temp)|("W:D1" %in% temp)){
# if(dep=="Y") {
# result=c(result,paste0(ifelse(any(str_detect(temp,"^M")),"c'","c"),j))
#
# } else{
# result=c(result,paste0(prefix,j))
#
# }
# j<-j+1
# } else if(dep %in% c(paste0("M",2:9))) {
# tempvar=temp[str_detect(temp,"^M[1-9]:")][1]
# temp1=paste0("d",substr(dep,2,2),substr(tempvar,2,2))
# if(m>1) temp1=paste0(temp1,m)
# result=c(result,temp1)
# m<-m+1
# } else{
# # result=c(result,paste0("b",l))
# # l<-l+1
# if(any(str_detect(temp,"^M[1-9]:"))){
# # tempvar=temp[str_detect(temp,"^M[1-9]:")][1]
# # cat("tempvar=",tempvar,"\n")
# # result=c(result,paste0(prefix,substr(tempvar,2,2),l))
# result=c(result,paste0(prefix,l))
# l<-l+1
# } else{
# result=c(result,paste0(prefix,j))
# l<-l+1
# }
#
# }
#
# } else if(temp[i] %in% c("X:W","W:X")){
# if(dep=="Y") {
# result=c(result,paste0(ifelse(any(str_detect(temp,"^M")),"c'","c"),j))
#
# } else{
# result=c(result,paste0(prefix,j))
#
# }
# j<-j+1
#
#
# } else if(str_detect(temp[i],"^D[0-9]")){
# if(dep=="Y") {
# result=c(result,paste0(ifelse("M" %in% temp,"c'","c"),j))
#
# } else{
# result=c(result,paste0(prefix,j))
#
# }
# j<-j+1
#
#
# } else if(str_detect(temp[i],"^M[1-9]:?")){
#
# if(dep %in% c(paste0("M",2:9))) {
# temp1=paste0("d",substr(dep,2,2),substr(temp[i],2,2))
# if(m>1) temp1=paste0(temp1,m)
# result=c(result,temp1)
# m<-m+1
# } else{
# # result=c(result,paste0("b",substr(temp[i],2,2),l))
# result=c(result,paste0("b",l))
# l=l+1
# }
# } else { #if(temp[i]=="M:W")
# result=c(result,paste0("b",l))
# l=l+1
#
# }
}
if(any(str_detect(result,"b"))){
result=str_replace(result,"c","c'")
}
result
if(!("c2" %in% result)) result[result=="c1"]="c"
if(!("c'2" %in% result)) result[result=="c'1"]="c'"
if(!("b2" %in% result)) result[result=="b1"]="b"
if(!dep %in% c("M1","M2","M3")){
if(!("a2" %in% result)) result[result=="a1"]="a"
}
if(!("f2" %in% result)) result[result=="f1"]="f"
if(!("g2" %in% result)) result[result=="g1"]="g"
if("W:X" %in% temp) {
result[result=="c'1"]="c'4"
result[result=="c'2"]="c'1"
result[result=="c'4"]="c'2"
}
# cat("result=",result,"\n")
result
}
#' Make Summary for Model Coefficients
#' @param fit A list of objects of class lm
#' @param labels optional list
#' @param vars optional list
#' @param moderator optional list
#' @param covar optional list
#' @param serial logical
#' @param data optional data.frame
#' @param prefix A character
#' @param constant A string vector
#' @param autoPrefix logical automatic numbering of prefix
#' @importFrom dplyr full_join
#' @importFrom purrr reduce
#' @importFrom stringr "%>%"
#' @importFrom tidyselect starts_with
#' @export
#' @return A data.frame
#' @examples
#' fit1=lm(mpg~wt,data=mtcars)
#' fit2=lm(mpg~wt*hp*am,data=mtcars)
#' fit=list(fit1,fit2)
#' labels=list(Y="mpg",X="wt",W="hp",Z="am")
#' modelsSummary(fit,labels=labels)
#' labels=list(Y="withdraw",M="affect",X="estress")
#' covar=list(name=c("ese","sex","age"),site=list(c("M","Y"),c("M","Y"),c("M","Y")))
#' modelsSummary(labels=labels,covar=covar,data=estress)
#' labels=list(X="dysfunc",M="negtone",W="negexp",Y="perform")
#' moderator=list(name="negexp",site=list(c("a","b","c")))
#' eq=tripleEquation(labels=labels,moderator=moderator,data=teams,mode=1)
#' fit=eq2fit(eq,data=teams)
#' modelsSummary(fit,labels=labels)
#' labels=list(X="cond",M="pmi",Y="reaction")
#' modelsSummary(labels=labels,data=pmi)
modelsSummary=function(fit=NULL,labels=NULL,vars=NULL,moderator=NULL,covar=NULL,serial=FALSE,data=NULL,prefix="b",constant="iy",autoPrefix=TRUE){
# prefix="b";constant="iy";autoPrefix=TRUE
if(!is.null(covar)){
for(i in seq_along(covar$name)){
labels[[paste0("C",i)]]=covar$name[i]
}
}
if(length(vars)>0){
if(is.null(vars$label)){
if(length(vars$name)==1){
labels[["W"]]=vars$name[[1]][1]
labels[["Z"]]=vars$name[[1]][2]
} else{
for(i in seq_along(vars$name)){
labels[[paste0("W",i)]]=vars$name[[i]][1]
labels[[paste0("Z",i)]]=vars$name[[i]][2]
}
}
} else{
if(length(vars$name)==1){
labels[[vars$label[[1]][1]]]=vars$name[[1]][1]
labels[[vars$label[[1]][2]]]=vars$name[[1]][2]
} else{
for(i in seq_along(vars$name)){
labels[[vars$label[[i]][1]]]=vars$name[[i]][1]
labels[[vars$label[[i]][2]]]=vars$name[[i]][2]
}
}
}
}
if(length(moderator)>0){
if(is.null(moderator$label)){
prefix=ifelse(length(vars)==0,"W","V")
if(length(moderator$name)==1){
labels[[prefix]]=moderator$name
} else{
for(i in 1:length(moderator$name)){
labels[[paste0(prefix,i)]]=moderator$name[i]
}
}
} else{
for(i in 1:length(moderator$label)){
labels[[moderator$label[i]]]=moderator$name[i]
}
}
}
if(is.null(fit)){
#eq=tripleEquation(labels=labels,vars=vars,moderator=moderator,covar=covar,data=data,mode=1)
eq=multipleMediation(labels=labels,vars=vars,moderator=moderator,covar=covar,serial=serial,data=data,mode=1)
fit=eq2fit(eq,data=data)
}
if("lm" %in% class(fit)) fit=list(fit)
count=length(fit)
df<-coef<-list()
modelNames=c()
if(length(constant)==1) constant=rep(constant,count)
if(length(prefix)==1) prefix=rep(prefix,count)
for(i in 1 :count){
df[[i]]=data.frame(summary(fit[[i]])$coef)
colnames(df[[i]])=paste0(c("coef","se","t","p"),i)
df[[i]][["name1"]]=rownames(df[[i]])
if(autoPrefix &(!is.null(labels))) {
temp=names(fit[[i]]$model)[1]
temp1=changeLabelName(temp,labels,add=FALSE)
if(temp1=="M") {
constant[i]="im"
prefix[i]="a"
} else if(temp1=="Y"){
constant[i]="iy"
prefix[i]="c"
temp2=changeLabelName(rownames(df[[i]]),labels,add=FALSE)
if("M" %in% temp2){
prefix[i]="c'"
}
}
}
df
if(autoPrefix &(!is.null(labels))) {
df[[i]][[paste0("label",i)]]=makeCoefLabel(rownames(df[[i]]),dep=names(fit[[i]]$model)[1],labels,constant[i],prefix[i])
} else{
df[[i]][[paste0("label",i)]]=c(constant[i],paste0(prefix[i],1:(nrow(df[[i]])-1)))
}
colnames(df[[i]])[5]="name1"
coef[[i]]=getInfo(fit[[i]])[1:5]
df[[i]]<-df[[i]] %>% select(starts_with("label"),everything())
modelNames=c(modelNames,names(fit[[i]]$model)[1])
}
if(!is.null(labels)) modelNames=changeLabelName(modelNames,labels,add=TRUE)
df
if(count==1){
mydf=df[[1]]
} else{
mydf<-reduce(df,full_join,by="name1")
}
mydf
mydf<-mydf %>% select("name1",everything())
rownames(mydf)=mydf[["name1"]]
mydf<-mydf[-1]
mydf[]=lapply(mydf,myformat)
mydf<-mydf[c(2:nrow(mydf),1),]
rownames(mydf)[nrow(mydf)]="Constant"
mydf
for(i in 1:count){
mydf[[5*i]]=pformat(mydf[[5*i]])
}
finalNames=rownames(mydf)
df2=data.frame(coef,stringsAsFactors = FALSE)
colnames(df2)=paste0("coef",1:ncol(df2))
finalNames=c(finalNames,c("Observations","R2","Adjusted R2","Residual SE","F statistic"))
res=full_join(mydf,df2,by=paste0("coef",1:count))
res[is.na(res)]=""
res
if(!is.null(labels)) finalNames=changeLabelName(finalNames,labels,add=TRUE)
rownames(res)=finalNames
res
class(res)=c("modelSummary","data.frame")
attr(res,"modelNames")=modelNames
res
}
#'S3 method print for object modelSummary
#'@param x Object of class modelSummary
#'@param ... additional arguments to pass to print.modelSummary
#'@importFrom stringr str_pad
#'@export
print.modelSummary=function(x,...){
count=ncol(x)/5
colwidth=37
left=25
total=left+colwidth*count+1
right=colwidth*count+1
cat(paste(rep("=",total),collapse = ""),"\n")
cat(paste0(centerPrint("",left),centerPrint("Consequent",right)),"\n")
cat(paste0(centerPrint("",left),paste(rep("-",right),collapse = "")),"\n")
names=attr(x,"modelNames")
cat(paste0(centerPrint("",left)))
for(i in 1:count){cat(centerPrint(names[i],colwidth))}
cat("\n")
cat(paste0(centerPrint("",left)))
for(i in 1:count) cat(paste0(rep("-",colwidth),collapse = "")," ")
cat("\n")
cat(paste0(centerPrint("Antecedent",left)))
for(i in 1:count) cat(paste0(centerPrint("",5),centerPrint("Coef",8),centerPrint("SE",8),centerPrint("t",8),centerPrint("p",8)," "))
cat("\n")
cat(paste(rep("-",total),collapse = ""),"\n")
for(i in 1:(nrow(x)-5)){
cat(centerPrint(rownames(x)[i],left))
for(j in 1:count){
for(k in 1:5){
if(k==1){
cat(str_pad(x[i,(j-1)*5+k],3,"left")," ")
} else{
cat(str_pad(x[i,(j-1)*5+k],6,"left")," ")
}
cat(ifelse((j==count)&(k==5),"\n",""))
}
}
}
cat(paste(rep("-",total),collapse = ""),"\n")
for(i in (nrow(x)-4):nrow(x)){
cat(centerPrint(rownames(x)[i],left))
for(j in 1:count){
cat(centerPrint(x[i,(j-1)*5+2],colwidth))
cat(ifelse(j==count,"\n",""))
}
}
cat(paste(rep("=",total),collapse = ""),"\n")
}
#' Print a string in center
#' @param string A string
#' @param width A numeric
#' @export
centerPrint=function(string,width){
str_pad(string,width,side="both")
}
#'Make number subscript
#'@param ft An object of class flextable
#'@param label string vector
#'@param vanilla logical
#'@importFrom officer fp_text
#'@importFrom flextable mk_par as_paragraph as_i as_sub
#'@importFrom stringr str_extract
numberSubscript=function(ft,label,vanilla){
add=ifelse(vanilla,1,0)
for(i in seq_along(label)){
temp=paste0("mk_par(ft,j=",(i-1)*(5+add)+2,
",value=as_paragraph(
as_i(stringr::str_extract(",label[i],",'[^0-9yYmM]*')),
as_i(as_sub(stringr::str_extract(",label[i],",'[0-9yYmM].*')))),
part='body')")
ft<-eval(parse(text=temp))
}
ft
}
#' Make Summary Table for Model Coefficients
#' @param x An object of class modelSummary
#' @param vanilla A logical
#' @param ... further arguments to be passed to modelsSummary()
#' @importFrom officer fp_border
#' @importFrom flextable flextable merge_h_range align hline_top hline add_header
#' @importFrom flextable bold fontsize width italic set_header_labels add_header_row
#' @importFrom flextable theme_zebra vline_left
#' @importFrom stats pf
#' @importFrom dplyr select
#' @importFrom tidyselect everything
#' @importFrom stats setNames
#' @export
#' @return A flextable
#' @examples
#' \donttest{
#' fit1=lm(mpg~wt,data=mtcars)
#' fit2=lm(mpg~wt*hp,data=mtcars)
#' fit3=lm(mpg~wt*hp*am,data=mtcars)
#' labels=list(X="wt",W="hp",Y="mpg",Z="am")
#' x=modelsSummary(fit1,labels=labels)
#' modelsSummaryTable(x)
#' modelsSummaryTable(x,vanilla=FALSE)
#' x=modelsSummary(list(fit1,fit2),labels=labels)
#' modelsSummaryTable(x)
#' modelsSummaryTable(x,vanilla=FALSE)
#' x=modelsSummary(list(fit1,fit2,fit3),labels=labels)
#' modelsSummaryTable(x)
#' modelsSummaryTable(x,vanilla=FALSE)
#'}
modelsSummaryTable=function(x=NULL,vanilla=TRUE,...){
# vanilla=TRUE
# require(tidyverse)
# require(flextable)
# require(officer)
# fit1=lm(mpg~wt,data=mtcars)
# fit2=lm(mpg~wt*hp,data=mtcars)
# labels=list(X="wt",W="hp",Y="mpg",Z="am")
# x=modelsSummary(list(fit1,fit2))
if(is.null(x)) {
x=modelsSummary(...)
}
if(!("modelSummary" %in% class(x))) {
x=modelsSummary(x,...)
}
x[x=="im"]="iM"
x[x=="iy"]="iY"
modelNames=attr(x,"modelNames")
modelNames
result=x
count=ncol(x)/5
count
result[["name1"]]=rownames(result)
if(vanilla){
if(count>1){
for(i in 2:count) result[[paste0("s",(i-1))]]=""
}
}
result<-result %>% select("name1",everything())
rowcount=nrow(result)
if(vanilla) {
col_keys=c("name1",names(result)[2:6])
if(count>1){
for(i in 1:(count-1)) {
col_keys=c(col_keys,paste0("s",i),names(result)[(i*5+2):(i*5+6)])
}
}
} else{
col_keys=names(result)
}
ft<-flextable(result,col_keys=col_keys)
ft
hlabel=c("Antecedent","","Coef","SE","t","p")
if(count>1){
for(i in 2:count){
if(vanilla) { hlabel=c(hlabel,"","","Coef","SE","t","p") }
else { hlabel=c(hlabel,"","Coef","SE","t","p") }
}
}
hlabel<-setNames(hlabel,col_keys)
hlabel=as.list(hlabel)
hlabel
ft<-ft %>% set_header_labels(values=hlabel)
colcount=5+ifelse(vanilla,1,0)
ft
for(i in 1:count){
ft<- ft %>% merge_h_range(i=(rowcount-4):rowcount,
j1=colcount*(i-1)+3,j2=colcount*(i-1)+6)
}
ft<- ft %>% align(align="center",part="all") %>%
hline_top(part="header",border=fp_border(color="white",width=0))
ft
for(i in 1:count){
ft <- ft %>% hline_top(j=((i-1)*colcount+2):(i*colcount),
part="header",border=fp_border(color="black",width=1))
}
big_border=fp_border(color="black",width=2)
hlabel=c("","",modelNames[1],rep("",3))
if(count>1){
for(i in 2:count){
if(vanilla) {hlabel=c(hlabel,"","",modelNames[i],rep("",3))}
else {hlabel=c(hlabel,"",modelNames[i],rep("",3))}
}
}
hlabel<-setNames(hlabel,col_keys)
hlabel=as.list(hlabel)
hlabel
length(hlabel)
length(col_keys)
count
colcount
ft
ft <- add_header_row(ft,values=hlabel,top=TRUE,
colwidths=rep(1,count*colcount+ifelse(vanilla,0,1)))
ft <- ft %>%
hline_top(j=2:(count*colcount++ifelse(vanilla,0,1)),part="header",border=fp_border(color="black",width=1))
ft
for(i in 1:count){
ft<-ft %>% hline(i=1,j=((i-1)*colcount+3):((i-1)*colcount+6),
part="header",border=fp_border(color="black",width=1))
}
for(i in 1:count){
ft <- ft %>% merge_h_range (i=1,j1=(i-1)*colcount+3,j2=(i-1)*colcount+6,
part="header")
}
ft
hlabel=list(name1="",coef1="Consequent")
ft<-ft %>%
add_header_row(top=TRUE,values=hlabel,
colwidths=c(1,count*colcount+ifelse(vanilla,0,1)-1)) %>%
hline_top(part="header",border=big_border) %>%
hline(i=1,j=2:(count*colcount+ifelse(vanilla,0,1)),part="header",
border=fp_border(color="black",width=1)) %>%
merge_h_range(i=1,j1=2,j2=count*colcount+ifelse(vanilla,0,1),part="header") %>%
align(align="center",part="header") %>%
align(align="right",part="body") %>%
bold(part="header") %>%
align(i=(nrow(x)-4):nrow(x),align="center",part="body") %>%
fontsize(part="all",size=12) %>%
hline(i=rowcount-5,border=fp_border(color="gray"),part="body")
ft
if(count>1){
if(vanilla) {
for(i in 1:(count-1)){
ft<-ft %>% width(j=i*6+1,width=0.001)
}
for(i in 1:count){
ft<-ft %>% width(j=(i-1)*6+2,width=0.4)
}
} else{
for(i in 1:count){
ft<-ft %>% width(j=(i-1)*5+2,width=0.4)
}
}
for(i in 1:(count)){
ft<-ft %>% italic(i=3,j=c(((i-1)*colcount+3):((i-1)*colcount+5)),
italic=TRUE,part="header")
}
} else{
ft<-ft %>% width(j=2,width=0.4)
}
ft
if(!vanilla){
ft <-ft %>%
theme_zebra(even_body="#EFEFEF",odd_body="transparent",
even_header ="#5B7778",odd_header="#5B7778") %>%
fontsize(size=12,part="all") %>%
align(align="center",part="header") %>%
align(j=1,align="center",part="body") %>%
align(j=2:(1+colcount*count),align="right",part="body") %>%
align(i=(nrow(x)-4):nrow(x),align="center",part="body") %>%
color(color="white",part="header") %>%
hline(j=2:(1+colcount*count),border=fp_border(color="black",width=1),
part="header") %>%
vline(j=1:(1+colcount*count),border=fp_border(color="black",width=1),
part="header") %>%
vline_left(border=fp_border(color="black",width=1),
part="header") %>%
hline(j=1:(1+colcount*count),border=fp_border(color="#EDBD3E",width=1),
part="body") %>%
vline(j=1:(1+colcount*count),border=fp_border(color="#EDBD3E",width=1),
part="body") %>%
vline_left(border=fp_border(color="#EDBD3E",width=1),
part="body")
}
ft
count=ncol(x)/5
label=paste0("label",1:count)
ft<-ft %>% numberSubscript(label=label,vanilla=vanilla) %>%
align(align="center",j=label,part="body")
ft<-ft %>% width(j=1,width=0.3) %>%
align(align="center",j=1,part="body")
if(vanilla) {
ft<- ft %>% width(j=2:((count-1)*6+2),width=1.1) %>%
width(j=1,width=0.3)
if(count>1) {
for(i in 1:(count-1)){
ft<-ft %>% width(j=i*6+1,width=0.001)
}
}
} else{
ft<- ft %>% width(j=2:((count-1)*5+2),width=1.1) %>%
width(j=1,width=0.3)
}
ft
}
#'Format a numeric vector
#'@param x A numeric vector
#'@param digits integer indicating the number of decimal places
#'@export
myformat=function(x,digits=3){
if(is.numeric(x)){
fmt=paste0("%.0",digits,"f")
x=sprintf(fmt,x)
}
x[x=="NA"]<-""
x
}
#' Make p value format
#'@param x A numeric vector
#'@export
pformat=function(x){
temp=substr(x,2,nchar(x))
temp[temp==".000"]="<.001"
temp
}
#'Get information of a model
#' @param fit object of class lm
#' @param digits integer indicating the number of decimal places
#' @export
#' @examples
#' fit=lm(mpg~wt*hp,data=mtcars)
#' getInfo(fit)
getInfo=function(fit,digits=3){
fmt=paste0("%.0",digits,"f")
r1=nrow(fit$model)
x<-summary(fit)
r2=sprintf(fmt,x$r.squared)
r3=sprintf(fmt,x$adj.r.squared)
r4=paste0(sprintf(fmt,x$sigma)," ( df = ",round(x$df[2]),")")
f=paste0("F(",round(x$fstatistic[2]),",",round(x$fstatistic[3]),") = ",
sprintf(fmt,x$fstatistic[1]))
p=sprintf(paste0("%0.",digits,"f"),pf(x$fstatistic[1L],
x$fstatistic[2L], x$fstatistic[3L], lower.tail = FALSE))
p
p=substr(p,2,digits+2)
if(p==".000") p="< .001"
else p=paste0("= ",p)
f=paste0(f,", p ",p)
MSE=sprintf(paste0("%0.",digits,"f"),sum(fit$residuals^2)/(r1-x$fstatistic[2]-1))
result=c(r1,r2,r3,r4,f,MSE)
result
}
Try the processR package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.