Source Code
reg_to_excel <- function( res_list , blk = "\t" , exp_coef = F , file_name = "/Users/Ronri_Rukeichi/Desktop/test.txt", reg_function = "lm" ){
def_funcs <- c("lm", "rq", "clm")
if(!reg_function %in% def_funcs ){
stop("指定された回帰関数は未対応です, clm or lm or rqのどれかを指定すべきです")
}
info_list <- lapply( res_list , function( rslt ){
if( reg_function == "lm" ){
smr <- summary(rslt)
coef_arr <- coef(smr)[,1]
se_arr <- coef(smr)[, 2]
pval_arr <- coef(smr)[, 4]
var_name_arr <- rownames(coef(smr))
coef_df <- data.frame(Var = var_name_arr , Coef = coef_arr, S.E.= se_arr , Pval = pval_arr )
N <- length(smr$residuals)
nparam <- slot(logLik((rslt)),"df")
val_logLik <- as.numeric(logLik((rslt)))
val_AIC <- AIC( rslt)
val_BIC <- BIC( rslt)
r_squared <- summary(rslt )$r.squared
adj_r_squared <- summary(rslt )$adj.r.squared
cri_names <- c("N" , "Number of Parameters" , "log-likelihood" , "AIC" , "BIC" , "R Squared" , "Adj. R Squared")
cri_values <- c( N , nparam, val_logLik , val_AIC , val_BIC , r_squared , adj_r_squared )
cri_df <- data.frame( Var = cri_names , Value = cri_values )
return(list( Coef = coef_df , Model = cri_df ) )
}else if( reg_function == "clm"){
smr <- summary(rslt)
coef_arr <- coef(smr)[,1]
se_arr <- coef(smr)[, 2]
pval_arr <- coef(smr)[, 4]
var_name_arr <- rownames(coef(smr))
coef_df <- data.frame(Var = var_name_arr , Coef = coef_arr, S.E.= se_arr , Pval = pval_arr )
N <- smr$nobs
nparam <- slot(logLik((rslt)),"df")
val_logLik <- as.numeric(logLik((rslt)))
val_AIC <- AIC( rslt)
val_BIC <- BIC( rslt)
cri_names <- c("N" , "Number of Parameters" , "log-likelihood" , "AIC" , "BIC" )
cri_values <- c( N , nparam , val_logLik , val_AIC , val_BIC )
cri_df <- data.frame( Var = cri_names , Value = cri_values )
return(list( Coef = coef_df , Model = cri_df ) )
}else if( reg_function == "rq"){
smr <- summary( rslt )
coef_df_list <- list()
cri_df_list <- list()
for( i in 1: length( smr ) ){
coef_arr <- ((smr[[i]])$coefficients)[,1]
se_arr <- (smr[[i]]$coefficients)[,2]
pval_arr <- (smr[[i]]$coefficients)[,4]
var_name_arr <- rownames((smr[[i]]$coefficients))
coef_df <- data.frame(Var = var_name_arr , Coef = coef_arr, S.E.= se_arr , Pval = pval_arr )
coef_df_list[[i]] <- coef_df
N <- nrow( rslt$residual)
nparam <- slot( logLik(rslt),"df")
val_logLik <- logLik(rslt)[i]
val_AIC <- AIC(rslt)[i]
val_BIC <- -2 * val_logLik + log( N ) * nparam
val_tau <- smr[[i]]$tau
cri_names <- c("N" , "Number of Parameters" , "log-likelihood" , "AIC" , "BIC", "Quantile" )
cri_values <- c( N , nparam , val_logLik , val_AIC , val_BIC, val_tau)
cri_df <- data.frame( Var = cri_names , Value = cri_values )
cri_df_list[[i]] <- cri_df
}
return(list( Coef = coef_df_list , Model = cri_df_list ) )
}
} )
mix_blank <- function( str_arr ,k=1 , blank_str=" " ){
return(as.vector( matrix(c( str_arr , rep( blank_str , length(str_arr) * k ) ) , nrow= (k + 1) , byrow=T ) ) )
}
pval_mark <- function( pval){
return(ifelse( pval >= 0.10 , " " , ifelse( pval >= 0.05 , "†" , ifelse( pval >= 0.01 , "*" , ifelse( pval >= 0.001 , "**" , "***" ) ) ) ))
}
library(dplyr)
coef_to_txt <- function( coef_df, exp_flag = F, round_digit = 4 ){
info_df <- dplyr::select( coef_df, Coef, S.E., Pval)
se_str <- paste("[", formatC(round(info_df$S.E. , round_digit ) , format= "f" , digits = round_digit) , "]" , sep="")
coef_str <- formatC( round( info_df$Coef , round_digit ) , format="f" , digits = round_digit )
est_str <- as.vector( matrix( c( coef_str , se_str ) , byrow=T , nrow = 2 ) )
p_smbl <- pval_mark( info_df$Pval)
p_smbl_arr <- mix_blank(p_smbl , k= 1 )
if( exp_flag == TRUE ){
exp_beta <- formatC( round( exp( info_df$Coef ), round_digit ) , digits = round_digit , format="f" )
exp_beta_str <- mix_blank( exp_beta, k = 1 )
return( cbind( est_str, p_smbl_arr , exp_beta_str) )
}else{
return( cbind( est_str, p_smbl_arr ) )
}
}
mdl_to_txt <- function( model_df , exp_flag=F){
cri_values <- formatC( model_df$Value , format="f" , digits = 3 )
if( exp_flag ){
ret_mat <- cbind( cri_values , rep( " " , length(cri_values ) ),rep( " " , length(cri_values ) ) )
}else{
ret_mat <- cbind( cri_values , rep( " " , length(cri_values ) ) )
}
return(ret_mat )
}
cbind_v2 <- function( mat1 , mat2 , blank_str = " "){
n1 <- nrow( mat1 )
n2 <- nrow( mat2 )
if( n1 > n2 ){
add_mat <- matrix( rep(" " , ncol(mat2 ) * (n1- n2 )), ncol= ncol(mat2) )
mat2 <- rbind( mat2 ,add_mat )
ret_mat <- ( cbind( mat1 , mat2 ) )
}else if( n1 < n2 ) {
add_mat <- matrix( rep(" " , ncol(mat1 ) * (n2- n1 )), ncol= ncol(mat1) )
mat1 <- rbind( mat1 ,add_mat )
ret_mat<- ( cbind( mat1 , mat2 ) )
}else if( n1 == n2 ) {
ret_mat <- cbind( mat1 , mat2 )
}
return( ret_mat )
}
if(reg_function %in% c( "lm" , "clm")){
var_names <- as.character( info_list[[length(info_list)]]$Coef$Var )
model_info_names <- as.character( info_list[[length(info_list)]]$Model$Var )
left_side <- matrix(c(as.vector( matrix(c(var_names , rep(" ",length(var_names))), nrow=2, byrow=T)), model_info_names) ,ncol=1)
if( exp_coef == T){
title_arr <- c("β", " ", "Exp(β)" )
}else{
title_arr <- c("Coef." , " " )
}
model_name_arr <- paste( "Model" ,1:length( info_list ) ,sep = "" )
upper_side <- matrix( c( mix_blank( model_name_arr , k = ifelse( exp_coef ==T , 2 , 1 ) ) , rep(title_arr,length(res_list ) )) , byrow = T , nrow= 2)
tbl_content <- NA
lower_side <- NA
lapply( info_list , function( info_elm ){
if( is.na( tbl_content ) ){
tbl_content <<- coef_to_txt(info_elm$Coef, exp_flag = exp_coef)
lower_side <<- mdl_to_txt( info_elm$Model,exp_flag = exp_coef)
} else{
tbl_content <<- cbind_v2(tbl_content , coef_to_txt(info_elm$Coef , exp_flag = exp_coef) )
lower_side <<- cbind( lower_side , mdl_to_txt( info_elm$Model,exp_flag = exp_coef) )
}
})
ret_mat <- cbind( rbind( matrix( c(" " , " ") , ncol=1 ) , left_side ) , rbind( upper_side , tbl_content , lower_side ) )
}else if(reg_function == "rq"){
info_list2 <- list()
for( i in 1:length(info_list[[1]]$Model) ){
info_list2[[i]] <- list()
}
cnt <- 0
lapply(info_list , function(info_elm){
cnt <<- cnt + 1
coef_cnt <- 0
lapply(info_elm$Coef , function( coef_info){
coef_cnt <<- coef_cnt + 1
info_list2[[coef_cnt]][[cnt]] <<- list()
info_list2[[coef_cnt]][[cnt]][["Coef"]] <<- coef_info
} )
model_cnt <- 0
lapply(info_elm$Model , function( mdl_info){
model_cnt <<- model_cnt + 1
info_list2[[model_cnt]][[cnt]][["Model"]] <<- mdl_info
} )
})
ret_mat_list <- lapply( info_list2 ,function(info_list){
var_names <- as.character( info_list[[length(info_list)]]$Coef$Var )
model_info_names <- as.character( info_list[[length(info_list)]]$Model$Var )
left_side <- matrix(c(as.vector( matrix(c(var_names , rep(" ",length(var_names))), nrow=2, byrow=T)), model_info_names) ,ncol=1)
if( exp_coef == T){
title_arr <- c("β", " ", "Exp(β)" )
}else{
title_arr <- c("Coef." , " " )
}
model_name_arr <- paste( "Model" ,1:length( info_list ) ,sep = "" )
upper_side <- matrix( c( mix_blank( model_name_arr , k = ifelse( exp_coef ==T , 2 , 1 ) ) , rep(title_arr,length(res_list ) )) , byrow = T , nrow= 2)
tbl_content <- NA
lower_side <- NA
lapply( info_list , function( info_elm ){
if( is.na( tbl_content ) ){
tbl_content <<- coef_to_txt(info_elm$Coef, exp_flag = exp_coef)
lower_side <<- mdl_to_txt( info_elm$Model,exp_flag = exp_coef)
} else{
tbl_content <<- cbind_v2(tbl_content , coef_to_txt(info_elm$Coef , exp_flag = exp_coef) )
lower_side <<- cbind( lower_side , mdl_to_txt( info_elm$Model,exp_flag = exp_coef) )
}
})
ret_mat <- cbind( rbind( matrix( c(" " , " ") , ncol=1 ) , left_side ) , rbind( upper_side , tbl_content , lower_side ) )
return(ret_mat)
})
ret_mat <- NULL
lapply( ret_mat_list , function(x){
ret_mat <<- rbind( ret_mat , x )
})
}
write.table(ret_mat , sep=blk , file=file_name , quote=F , row.names = F , col.names=F )
return( info_list )
}
