Nothing
R/MakeTable.R
In MonteCarlo: Automatic Parallelized Monte Carlo Simulations
#######################################################################################################################################
#
# MakeTable generates tables from output of MonteCarlo that can be directly copied to LaTeX.
# The ordering of the variables to columns and rows can be determined by user.
#
#######################################################################################################################################
#' helper function to create index string
#' @keywords internal
make_index<-function(letter,number){
help<-paste(paste(letter,1:number,",",sep=""),collapse="")
help<-substr(help,1,(nchar(help)-1))
help
}
#' helper function to average over results from MonteCarlo() run
#' @importFrom stats na.omit
#' @keywords internal
collapse_results<-function(output, collapse){
ret<-list()
for(i in 1:length(output)){
out<-output[[i]]
num_param<-length(dim(out))-1
help<-make_index("i",num_param)
erg<-array(NA,dim=dim(out)[1:num_param])
loop<-paste(paste(paste("for(i", 1:num_param, " in 1:", dim(out)[1:num_param], "){", sep=""), collapse=""),
paste(c("erg[", help, "]<-"), collapse=""),
paste(c(collapse[[i]], "(na.omit(out[",help,",]))"), collapse=""),
paste(rep("}", num_param), collapse=""), collapse="")
eval(parse(text=loop))
dimnames(erg)<-dimnames(out)[1:num_param]
ret[[i]]<-erg
}
names(ret)<-names(output)
ret
}
########################## MakeTable ####################################
#' @title Create LaTeX Tables From MonteCarlo Output.
#' @description \code{MakeTable} generates LaTeX tables with user determined ordering from the output of \code{MonteCarlo}.
#' @details
#'
#' To generate a two-dimensional table from the high dimensional array of simulation results in output,
#' the results have to be stacked into rows and columns. The orderning of the resulting table is defined by the ordering
#' in \code{rows} and \code{cols} that are ordered from the inside of the desired table to the outside.
#'
#' The first two elements specify a matrix for all possible combinations from the grids for the two desired parameters.
#' For a third parameter, the matrices for the first two can be stacked in columns
#' - one over the other - or in rows - one next to the other. The result of this is a larger matrix. This matrix produced
#' for each value of the grid for the fourth parameter can again be stacked into rows or columns and so on. Consult the example.
#'
#' To compile a Tex document containing the generated table include '\\usepackage\{multirow\}' in the preamble.
#'
#' To make the resultig tables more comprehensive, parameter grids of length one are dropped from the table
#' (unless they are the only value in either cols or rows) and the information is added to the caption.
#'
#' In case that the simulation function \code{func} used in \code{MonteCarlo} returns a list with more than one element
#' (for example the results of two competing estimators or tests) separate tables are generated for each list element.
#'
#' If it is desired to include the list elements in a single table, this behavior can be modified by adding "list"
#' in one of the vectors \code{rows} or \code{cols} (see examples).
#'
#' @param output List of class MonteCarlo generated by \code{MonteCarlo}.
#' @param rows Vector of parameter names to be stacked in the rows of the table. Ordered from the inside to the outside.
#' @param cols Vector of parameter names to be stacked in the cols of the table. Ordered from the inside to the outside.
#' @param digits Maximal number of digits displayed in table. Default is \code{digits=4}.
#' @param collapse Optional list of the same length as the list returned by the function *func* supplied to \code{MonteCarlo()}.
#' This list specifies the names of functions to be applied to the repective components of \code{output} when collapsing the results to a table.
#' By default means are taken. Another example could be \code{sd()}. Currently, functions supplied have to return a scalar.
#' @param transform Optional argument to transform the output table (for example from MSE to RMSE). If a function is supplied
#' it is applied to all tables. Alternatively, a list of functions can be supplied that has the same length as the list
#' returned by the function *func* supplied to \code{MonteCarlo()}.
#' For tables that are supposed to stay unchanged set list element to \code{NULL}.
#' @param include_meta Boolean that determines whether the meta data provided by \code{summary()} is included in comments below the table.
#' Default is \code{include_meta==TRUE}.
#' @param partial_grid Optional list with the elements named after the parameters for which only a part of the grid values is
#' supposed to be included in the table. Each component of the list is a vector that specifies the grid values of interest.
#' @param width_mult Scaling factor for width of the output table. Default is \code{width_mult=1}.
#' @examples
#' test_func<-function(n,loc,scale){
#' sample<-rnorm(n, loc, scale)
#' stat<-sqrt(n)*mean(sample)/sd(sample)
#' decision<-abs(stat)>1.96
#' return(list("decision"=decision))
#' }
#'
#' n_grid<-c(50,100,250,500)
#' loc_grid<-seq(0,1,0.2)
#' scale_grid<-c(1,2)
#'
#' param_list=list("n"=n_grid, "loc"=loc_grid, "scale"=scale_grid)
#' erg<-MonteCarlo(func=test_func, nrep=250, param_list=param_list, ncpus=1)
#' str(erg)
#'
#' rows<-c("n")
#' cols<-c("loc","scale")
#' MakeTable(output=erg, rows=rows, cols=cols, digits=2)
#'
#'
#' #-------- Further Examples: Compare Mean and Median as Estimators for the Expected Value
#'
#' # define func
#'
#' func<-function(n,loc,scale){
#'
#' # generate sample
#' sample<-rnorm(n, loc, scale)
#'
#' # calculate estimators
#' mean_sample<-mean(sample)
#' median_sample<-median(sample)
#'
#' # calculate bias
#' bias_mean_sample<-mean_sample-loc
#' bias_median_sample<-median_sample-loc
#'
#' # return results
#' return(list("mean for calculation of sd"=mean_sample,
#' "bias_mean"=bias_mean_sample,
#' "median for calculation of sd"=median_sample,
#' "bias_median"=bias_median_sample))
#' }
#'
#' n_grid<-c(50,100,250,500)
#' loc_grid<-seq(0,1,0.2)
#' scale_grid<-c(1,2)
#'
#' param_list=list("n"=n_grid, "loc"=loc_grid, "scale"=scale_grid)
#' erg_mean_median<-MonteCarlo(func=func, nrep=250, param_list=param_list, ncpus=1)
#'
#' rows<-c("n")
#' cols<-c("loc","scale")
#'
#' # use partial_grid
#'
#' MakeTable(output=erg_mean_median, rows=rows, cols=cols, digits=2,
#' partial_grid=list("n"=c(1,3), "loc"=c(1,3,5)), include_meta=FALSE)
#'
#' # use collapse to calculate standard deviation and bias
#'
#' collapse<-list("sd", "mean", "sd", "mean")
#' MakeTable(output=erg_mean_median, rows=rows, cols=cols, digits=2,
#' collapse=collapse, include_meta=FALSE)
#'
#' # merge all results in one table
#'
#' MakeTable(output=erg_mean_median, rows=c("n","loc"), cols=c("scale","list"),
#' digits=2, collapse=collapse, include_meta=FALSE)
#'
#' # transform the results for better scaling
#'
#' scale_table_10<-function(x){x*10}
#'
#' MakeTable(output=erg_mean_median, rows=c("n","loc"), cols=c("scale","list"),
#' digits=2, collapse=collapse,
#' transform=list(scale_table_10, NULL, function(x){x*10}, NULL),
#' include_meta=FALSE)
#'
#'@export
MakeTable<-function(output, rows, cols, digits=4, collapse=NULL, transform=NULL, include_meta=TRUE, width_mult=1, partial_grid=NULL){
if(class(output)!="MonteCarlo")stop("output has to be an object of class MonteCarlo.")
if(is.null(collapse)==FALSE){
for(i in 1:length(collapse)){
if(length(do.call(collapse[[i]], list(seq(1,10,1))))>1)stop("Functions included in collapse have to return a scalar.")
}
}
full_output_object<-output
param_list<-output$param_list
output<-output$results
if(is.null(partial_grid)==FALSE){
sel<-partial_grid
#param_list_new<-list()
sel_dims<-which(names(param_list)%in%names(sel))
for(i in 1:length(sel_dims)){
param_list[[sel_dims[i]]]<-param_list[[sel_dims[i]]][sel[[i]]]
}
}
for(i in 1:length(param_list)){
assign(paste(names(param_list)[i],"_grid",sep=""),param_list[[i]])
}
if(any(rows%in%cols))stop("Names in rows and cols must be unique.")
helpnames<-c(rows,cols)%in%c(names(param_list),"list")
if(any(helpnames==FALSE))stop(paste("The parameter", c(rows,cols)[which(helpnames==FALSE)],"is not part of param_list."))
if(is.null(collapse)){
collapse<-list()
for(i in 1:length(output)){collapse[[i]]<-"mean"}
}
output<-collapse_results(output, collapse=collapse) # from raw output average over results, so that monte carlo results are saved in list of large arrays
# apply function(s) passed through transform to output
if(is.null(transform)==FALSE){
if(any(c(is.function(transform), is.list(transform)))==FALSE)stop("transform must be either NULL, a function or a list of functions!")
if(is.list(transform)){if(length(transform)!=length(output))stop("List supplied as transform must be of the same lengths as output.")}
if(length(transform)==1){ # if only a single function is passed to MakeTable apply it to each array in collapsed output list
help<-list()
for(i in 1:length(output)){help[[i]]<-transform} # convert transform to list of functions that repeats the function transform
transform<-help
}
for(i in 1:length(output)){
if(is.null(transform[[i]])==FALSE){output[[i]]<-transform[[i]](output[[i]])} # apply i-th element of function list to i-th output array
}
}
# turn list elements in additional array dimensions if "list" is included in "rows" or "cols"
output_aux<-NULL
if("list"%in%unique(c(rows,cols))){
for(i in 1:length(output)){
output_aux<-abind(output_aux, output[[i]], along=(length(dim(output[[1]]))+1))
}
dimnames_aux<-dimnames(output[[1]])
dimnames_aux[[(length(dim(output[[1]]))+1)]]<-paste("list=",names(output), sep="")
dimnames(output_aux)<-dimnames_aux
list_grid<-names(output)
param_list$list<-list_grid
output<-list(output_aux)
names(output)<-paste(param_list$list,collapse=", ")
}
#### ----------------------------------------------------------------------------------- ###
for(lll in 1:length(output)){ # iterate over list elements to create own table for each variable returned by function fun
out<-output[[lll]] # select element from list
if(is.null(partial_grid)==FALSE){
sel<-partial_grid
array_selector<-rep("",length(dim(output[[1]])))
for(i in 1:length(sel_dims)){
array_selector[sel_dims[i]]<-paste("c(",paste(sel[[i]], collapse=","),")", collapse="")
}
array_selector<-paste("[", paste(array_selector, collapse=","),"]", collapse="")
eval(parse(text=paste("out<-out", array_selector, sep="")))
}
if(length(dim(out))==1){
if(is.null(rows)){
aux_dimnames<-list()
aux_dimnames[[1]]<-""
aux_dimnames[[2]]<-dimnames(out)[[1]]
out<-array(out, dim=c(1,dim(out)))
}
if(is.null(cols)){
aux_dimnames<-list()
aux_dimnames[[1]]<-dimnames(out)[[1]]
aux_dimnames[[2]]<-""
out<-array(out, dim=c(dim(out),1))
}
dimnames(out)<-aux_dimnames
}
## drop all dimensions from out-array that are equal to 1 (and thus unneccesary) and pass parameter information to description
pass_to_info<-NULL
if(length(dim(out))>2){
if(any(dim(out)==1)){
select<-which(dim(out)==1)
#------------ Make Sure that there is always at least one element in rows and cols ---------------#
if(all(rows%in%names(param_list)[select])){
select<-select[-1]
warning("All parameter grids in rows have only one element. Therefore they are superfluous.")
}
if(all(cols%in%names(param_list)[select])){
select<-select[-1]
warning("All parameter grids in cols have only one element. Therefore they are superfluous.")
}
#-----------------------------------------------------------------------------------------------------------#
if(length(select)>0){
pass_to_info<-as.character(dimnames(out)[select]) # add parameter info about dropped dimensions to caption
dims<-dim(out)
n_dims<-length(dims)
sel_str<-"out<-array(out["
for(i in 1:n_dims){
sel_str<-c(sel_str,if(i<n_dims){if(dims[i]==1){"1,"}else{","}}else{if(dims[i]==1){"1"}else{""}})
}
eval(parse(text=paste(c(sel_str,"], dim=dims[-select], dimnames=dimnames(out)[-select])"), collapse="")))
p_name<-unlist(strsplit(pass_to_info, split="="))[-(1:length(select))*2]
if(any(p_name%in%rows)){rows<-rows[-which(rows%in%p_name)]}
if(any(p_name%in%cols)){cols<-cols[-which(cols%in%p_name)]}
}
}
}
### escape special characters
pass_to_info<-gsub(pattern="_", replacement=paste("\\\\", "_", sep=""), pass_to_info)
###
#----- replace this part with helper function
dims<-dim(out)
n_dims<-length(dims)
all_names<-dimnames(out)
dim_names<-0
for(i in 1:(length(all_names))){dim_names[i]<-unlist(strsplit(all_names[[i]], split="="))[1]}
#----------------------------------------------------------------------------------------------#
if(any(na.omit(dim_names)%in%c(rows,cols)==FALSE))stop("rows and cols must contain all parameter names unless the grid has only one value.")
###--- rearrange array so that first dimension corresponds to first variable for row selected and
###--- second dimension has to correspond to first column selected
if(length(dim(out))>1){
sel<-c(which(dim_names==rows[1]),which(dim_names==cols[1]))
help_vec<-1:n_dims
perm<-c(sel,help_vec[-which(help_vec%in%sel)])
out<-aperm(out,perm=perm)
}
#----- replace this part with helper function
dims<-dim(out)
all_names<-dimnames(out)
dim_names<-0
for(i in 1:length(all_names)){dim_names[i]<-unlist(strsplit(all_names[[i]], split="="))[1]}
#----------------------------------------------------------------------------------------------#
###------------ construct index for interation over dimensions of out
###------------ make vectors that contain grid lengths for all variables in rows and columns but the first in each
ind<-rep("NA",(n_dims))
col_dims<-row_dims<-NULL
if(length(rows)>1){
for(i in 2:length(rows)){
sel_row<-(which(dim_names==rows[i]))
ind[sel_row]<-paste("i",i-1, sep="")
row_dims<-c(row_dims,dims[sel_row]) # dim of array corresponds to length of grid
}}
if(length(cols)>1){
for(j in 2:length(cols)){
sel_col<-(which(dim_names==cols[j]))
ind[sel_col]<-paste("j",j-1, sep="")
col_dims<-c(col_dims,dims[sel_col])
}}
ind<-paste(ind[-c(1,2)], collapse=",") # ignore the first two dimensions since these are fixed
############# Construct loops to generate matrix in the order specified by rows and cols #################
loops_rows<-length(rows)-1 # determine number of loops for rows
loops_cols<-length(cols)-1 # determine number of loops for columns
## inner loop runs over rows. if one block is completed the outer grid combines block of rows to columns
## the elementary building block is the matrix consisting of the first two dimensions of out,
## that correspond to the first row and the first column specified by the user.
## between all rows of these matrices a row of NAs is added.
## when columns are combined in the outer loop, columns are also seperated using a column of NAs
if(length(dim(out))>2){
inner_cols<-NULL
build_string<-paste(c(
if(loops_cols>0){paste("for(j",loops_cols:1," in 1:","col_dims[",loops_cols:1,"]){", sep="")}else{""},
"inner_rows<-NULL;",
if(loops_rows>0){paste("for(i",loops_rows:1," in 1:","row_dims[",loops_rows:1,"]){", sep="")}else{""},
paste("inner_rows<-rbind(inner_rows,matrix(out[,,",ind,"],dims[1],dims[2]),rep(NA,dims[2]))"),
rep("}",loops_rows),
";",
"inner_cols<-cbind(inner_cols,inner_rows,rep(NA,dims[1]+1))",
rep("}",loops_cols)), collapse="")
eval(parse(text=build_string))
erg_mat<-(inner_cols)
}else{
erg_mat<-rbind(cbind(out,NA),NA)
}
###------ for better readability add column of NAs between blocks for each grid value of the third column variable
if(length(cols)>2){
count_col<-dims[2]*col_dims[1]+col_dims[1]
rep_col<-dim(erg_mat)[2]/count_col
startstop_col<-matrix(NA,rep_col,2)
for(i in 1:rep_col){
startstop_col[i,]<-c((i-1)*count_col+1,i*count_col)
}
erg_mat2<-matrix(NA,nrow(erg_mat),ncol(erg_mat)+rep_col)
for(i in 1:rep_col){
erg_mat2[,((startstop_col[i,1]+(i-1)):(startstop_col[i,2]+(i-1)))]<-erg_mat[,(startstop_col[i,1]:startstop_col[i,2])]
}
erg_mat<-erg_mat2
}
###------ for better readability add row of NAs between blocks for each grid value of the third row variable
if(length(rows)>2){
count_row<-dims[1]*row_dims[1]+row_dims[1]
rep_row<-dim(erg_mat)[1]/count_row
startstop_row<-matrix(NA,rep_row,2)
for(i in 1:rep_row){startstop_row[i,]<-c((i-1)*count_row+1,i*count_row)}
erg_mat3<-matrix(NA,nrow(erg_mat)+rep_row,ncol(erg_mat))
for(i in 1:rep_row){
erg_mat3[((startstop_row[i,1]+(i-1)):(startstop_row[i,2]+(i-1))),]<-erg_mat[(startstop_row[i,1]:startstop_row[i,2]),]
}
erg_mat<-erg_mat3
}
############################################################
# Note that descriptions for rows and columns are handled differently due to the different behaviour of
# multicolumn and multirow in LaTeX. since multirow fits in one column, the descriptions for the rows can
# simply be included in the matrix that is supposed to be printed later.
# multicolumn on the other hand requires the omission of "&"s, so that they fit into LaTeX array. headers for
# the columns are therefore collected in seperate list
heads<-list()
# inner header
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
if(length(cols)>1){
help_head1<-eval(parse(text=paste("rep(c(paste(",paste(cols[1],"_grid",sep=""),"),NA),col_dims[1])",sep="")))
head1<-rep(c(help_head1,if(length(cols)>2){NA}else{NULL}),prod(col_dims[-1]))
}else{
if(is.null(cols)){head1<-c("",NA)}else{head1<-c(paste(get(paste(cols[1],"_grid",sep=""))),NA)
}
}
heads[[1]]<-head1
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# inner rownames
if(length(rows)>1){
help_rows1<-eval(parse(text=paste("rep(c(paste(",paste(rows[1],"_grid",sep=""),"),NA),row_dims[1])",sep="")))
}else{
if(is.null(rows)){help_rows1<-c("",NA)
}else{
help_rows1<-eval(parse(text=paste("rep(c(paste(",paste(rows[1],"_grid",sep=""),"),NA),1)",sep="")))
}
}
if(length(rows)>2){rows1<-rep(c(help_rows1,NA),prod(row_dims[-1]))}else{rows1<-help_rows1}
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# inner table with names
erg_mat4<-rbind(c(paste(rows[1],"/",cols[1], sep=""),NA,head1),rep(NA,length(head1)+2),cbind(rows1,rep(NA,length(rows1)),erg_mat))
dimnames(erg_mat4)<-NULL
erg_mat<-erg_mat4
################################################################################
##----------------------- In Case of multiple layers of rows or cols create additional headers ---------------##
## more than one layer of columns
if(length(cols)>1){
help_head2<-eval(parse(text=paste("paste('\\\\multicolumn{'",",","dims[2]",",","'}{c}{'",",",paste(cols[2],"_grid",sep=""),",","'}'",")")))
help_head2b<-rep(NA,2*col_dims[1]-1)
help_head2b[seq(1,length(help_head2b),2)]<-help_head2
if(length(col_dims[-1])>0){
head2<-rep(c(help_head2b,rep(NA,2)),prod(col_dims[-1]))}else{head2<-help_head2b}
heads[[2]]<-head2
}
n_multicol<-c(1,dims[2])
## more than two layers of columns
if(length(cols)>2){
for(i in 3:length(cols)){
col_mult<-if(i==3){1}else{2}
n_multicol[i]<-(n_multicol[(i-1)]+col_mult)*col_dims[(i-2)]-col_mult
assign(paste("help_head",i,sep=""),eval(parse(text=paste("paste('\\\\multicolumn{'",",","paste(n_multicol[i])",",","'}{c}{'",",",paste(cols[i],"_grid",sep=""),",","'}'",")",sep=""))))
assign(paste("head",i,sep=""),NULL)
eval(parse(text=paste("for(j in 1:length(",paste("help_head",i,sep=""),")){",paste("head",i,sep=""),"<-c(",paste("head",i,sep=""),",",paste("help_head",i,"[j]",sep=""),",NA,NA)}")))
heads[[i]]<-rep(get(paste("head",i,sep="")),prod(col_dims[-(1:(i-1))]))
}
}
## more than one layer of rows
if(length(rows)>1){
help_rows2<-eval(parse(text=paste("paste('\\\\multirow{'",",","dims[1]",",","'}{*}{'",",",paste(rows[2],"_grid",sep=""),",","'}'",")")))
help_rows2b<-rep(NA,length(help_rows2)*(dims[1]+1))
help_rows2b[seq(1,length(help_rows2b),dims[1]+1)]<-help_rows2
if(length(rows)>2){
rows2<-c(rows[2],NA,rep(c(help_rows2b,NA),prod(row_dims[-1])))
}else{
rows2<-c(rows[2],NA,help_rows2b)
}
}
n_multirow<-c(1,dims[1])
## more than two layers of rows
if(length(rows)>2){
for(i in 3:length(rows)){
row_mult<-if(i==3){1}else{2}
n_multirow[i]<-(n_multirow[(i-1)]+row_mult)*row_dims[(i-2)]-row_mult
assign(paste("help_rows",i,sep=""),eval(parse(text=paste("paste('\\\\multirow{'",",","paste(n_multirow[i])",",","'}{*}{'",",",paste(rows[i],"_grid",sep=""),",","'}'",")",sep=""))))
assign(paste("rows_help",i,sep=""),NULL)
eval(parse(text=
paste("for(j in 1:",
paste(length(get(paste("help_rows",i,sep="")))),"){",
paste("rows_help",i,sep=""),"<-c(",
paste("rows_help",i,sep=""),",",
paste("help_rows",i,"[j],",sep=""),
paste(paste(paste(rep(NA,n_multirow[i]+1)),collapse=","),")}",collapse=""))
))
assign(paste("rows",i,sep=""),c(rows[i],NA,rep(get(paste("rows_help",i,sep="")),prod(row_dims[-(1:(i-1))]))))
}
}
##---------------------------------------------------------------------------------##
erg_mat5<-erg_mat
if(length(rows)>1){for(i in 2:length(rows)){erg_mat5<-cbind(get(paste("rows",i, sep="")),erg_mat5)}}
drop_col<-NULL
for(i in 1:ncol(erg_mat5)){if(sum(is.na(erg_mat5[,ncol(erg_mat5)+1-i])==FALSE)==0){drop_col<-c(drop_col,i)}else{break}}
drop_row<-NULL
for(i in 1:nrow(erg_mat5)){if(sum(is.na(erg_mat5[nrow(erg_mat5)+1-i,])==FALSE)==0){drop_row<-c(drop_row,i)}else{break}}
erg_mat6<-erg_mat5[-c(nrow(erg_mat5)+1-drop_row),-c(ncol(erg_mat5)+1-drop_col)]
erg_mat7<-matrix("&",nrow(erg_mat6),ncol(erg_mat6)*2-1)
###------ reformat results so that the output is printed with specified number of digits
aux<-erg_mat6[-c(1,2),-c(1:length(rows))]
sel<-which(is.na(aux)==FALSE)
aux[sel]<-format(round(as.numeric(as.vector(aux)[sel]),digits=digits), nsmall=digits, scientific=FALSE)
erg_mat6[-c(1,2),-c(1:length(rows))]<-aux
#########
erg_mat7[,seq(1,ncol(erg_mat7),2)]<-erg_mat6
erg_mat7[which(is.na(erg_mat7))]<-""
###------ Define all character strings needed for header and footer of the table in vectors ########
preamble<-c("\\begin{table}[h]","\n",
"\\centering","\n",
paste("\\resizebox{",width_mult,"\\textwidth}{!}{%", collapse=""),"\n",
paste("\\begin{tabular}{",paste(rep("r",((ncol(erg_mat7)-1)/2+1)), collapse=""),"}"),"\n",
"\\hline","\\hline","\\\\","\\\\","\n")
footer<-c("\\\\","\n","\\\\","\n","\\hline","\\hline","\n",
"\\end{tabular}%","\n",
"}","\n",
paste("\\caption{",gsub(pattern="_", replacement=paste("\\\\","_", sep=""), names(output)[lll]),
if(is.null(pass_to_info)==FALSE){paste(pass_to_info, collapse=",")}else{""},"}")
,"\n",
"\\end{table}", "\n")
for(i in 1:length(heads)){
help<-rep("&",length(heads[[i]])*2-1) # include "&" inbetween elements in header to seperate columns of table in LaTeX
help[seq(1,length(help),2)]<-heads[[i]]
heads[[i]]<-help
heads[[i]][which(is.na(heads[[i]]))]<-"" # replace all NA values with whitespace
heads[[i]]<-gsub(pattern="_", replacement=paste("\\\\","_", sep=""), heads[[i]])
}
###------ escape underscore in variable names
erg_mat7<-gsub(pattern="_", replacement=paste("\\\\","_", sep=""), erg_mat7)
cols<-gsub(pattern="_", replacement=paste("\\\\","_", sep=""), cols)
###-------------------- Loops to print the table from its elements using cat -------------------###
for(i in 1:length(heads)){
while(heads[[i]][length(heads[[i]])]==""){
heads[[i]]<-heads[[i]][1:(length(heads[[i]])-2)]
}
}
for(i in 1:length(preamble)){cat(preamble[i])}
if(length(cols)>1){
for(i in 1:(length(heads)-1)){
cat(rep("&",length(rows)-1),paste(cols[length(heads)+1-i]),"&&",heads[[length(heads)+1-i]],"\\\\","\n")
}}
for(i in 1:nrow(erg_mat7)){cat(erg_mat7[i,],"\\\\","\n")}
for(i in 1:length(footer)){cat(footer[i])}
if(length(output)>lll){cat("\n","\n","\n")}
###------------------------------------------------------------------------------------------------###
} # finish loop over all list elements in output of MonteCarlo()
###-------- Print information provided by summary.MonteCarlo(output) in comments below table.
if(include_meta==TRUE){
cat("%\n")
if(is.null(transform)){cat("% transform = NULL","\n")}else{cat("% transform: ",paste(unlist(transform), collapse=", "),"\n")}
cat("% collapse: ", paste(unlist(collapse), collapse=", "),"\n")
summ_out<-capture.output(summary(full_output_object))
cat("%","\n")
for(i in 1:length(summ_out)){
cat("% ",summ_out[[i]],"\n")
}
}
###---------------------------------------
# End function.
}
#######################################################################################################################################
Try the MonteCarlo package in your browser
Any scripts or data that you put into this service are public.
MonteCarlo documentation built on May 2, 2019, 4:05 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.
#######################################################################################################################################
#
# MakeTable generates tables from output of MonteCarlo that can be directly copied to LaTeX.
# The ordering of the variables to columns and rows can be determined by user.
#
#######################################################################################################################################
#' helper function to create index string
#' @keywords internal
make_index<-function(letter,number){
help<-paste(paste(letter,1:number,",",sep=""),collapse="")
help<-substr(help,1,(nchar(help)-1))
help
}
#' helper function to average over results from MonteCarlo() run
#' @importFrom stats na.omit
#' @keywords internal
collapse_results<-function(output, collapse){
ret<-list()
for(i in 1:length(output)){
out<-output[[i]]
num_param<-length(dim(out))-1
help<-make_index("i",num_param)
erg<-array(NA,dim=dim(out)[1:num_param])
loop<-paste(paste(paste("for(i", 1:num_param, " in 1:", dim(out)[1:num_param], "){", sep=""), collapse=""),
paste(c("erg[", help, "]<-"), collapse=""),
paste(c(collapse[[i]], "(na.omit(out[",help,",]))"), collapse=""),
paste(rep("}", num_param), collapse=""), collapse="")
eval(parse(text=loop))
dimnames(erg)<-dimnames(out)[1:num_param]
ret[[i]]<-erg
}
names(ret)<-names(output)
ret
}
########################## MakeTable ####################################
#' @title Create LaTeX Tables From MonteCarlo Output.
#' @description \code{MakeTable} generates LaTeX tables with user determined ordering from the output of \code{MonteCarlo}.
#' @details
#'
#' To generate a two-dimensional table from the high dimensional array of simulation results in output,
#' the results have to be stacked into rows and columns. The orderning of the resulting table is defined by the ordering
#' in \code{rows} and \code{cols} that are ordered from the inside of the desired table to the outside.
#'
#' The first two elements specify a matrix for all possible combinations from the grids for the two desired parameters.
#' For a third parameter, the matrices for the first two can be stacked in columns
#' - one over the other - or in rows - one next to the other. The result of this is a larger matrix. This matrix produced
#' for each value of the grid for the fourth parameter can again be stacked into rows or columns and so on. Consult the example.
#'
#' To compile a Tex document containing the generated table include '\\usepackage\{multirow\}' in the preamble.
#'
#' To make the resultig tables more comprehensive, parameter grids of length one are dropped from the table
#' (unless they are the only value in either cols or rows) and the information is added to the caption.
#'
#' In case that the simulation function \code{func} used in \code{MonteCarlo} returns a list with more than one element
#' (for example the results of two competing estimators or tests) separate tables are generated for each list element.
#'
#' If it is desired to include the list elements in a single table, this behavior can be modified by adding "list"
#' in one of the vectors \code{rows} or \code{cols} (see examples).
#'
#' @param output List of class MonteCarlo generated by \code{MonteCarlo}.
#' @param rows Vector of parameter names to be stacked in the rows of the table. Ordered from the inside to the outside.
#' @param cols Vector of parameter names to be stacked in the cols of the table. Ordered from the inside to the outside.
#' @param digits Maximal number of digits displayed in table. Default is \code{digits=4}.
#' @param collapse Optional list of the same length as the list returned by the function *func* supplied to \code{MonteCarlo()}.
#' This list specifies the names of functions to be applied to the repective components of \code{output} when collapsing the results to a table.
#' By default means are taken. Another example could be \code{sd()}. Currently, functions supplied have to return a scalar.
#' @param transform Optional argument to transform the output table (for example from MSE to RMSE). If a function is supplied
#' it is applied to all tables. Alternatively, a list of functions can be supplied that has the same length as the list
#' returned by the function *func* supplied to \code{MonteCarlo()}.
#' For tables that are supposed to stay unchanged set list element to \code{NULL}.
#' @param include_meta Boolean that determines whether the meta data provided by \code{summary()} is included in comments below the table.
#' Default is \code{include_meta==TRUE}.
#' @param partial_grid Optional list with the elements named after the parameters for which only a part of the grid values is
#' supposed to be included in the table. Each component of the list is a vector that specifies the grid values of interest.
#' @param width_mult Scaling factor for width of the output table. Default is \code{width_mult=1}.
#' @examples
#' test_func<-function(n,loc,scale){
#' sample<-rnorm(n, loc, scale)
#' stat<-sqrt(n)*mean(sample)/sd(sample)
#' decision<-abs(stat)>1.96
#' return(list("decision"=decision))
#' }
#'
#' n_grid<-c(50,100,250,500)
#' loc_grid<-seq(0,1,0.2)
#' scale_grid<-c(1,2)
#'
#' param_list=list("n"=n_grid, "loc"=loc_grid, "scale"=scale_grid)
#' erg<-MonteCarlo(func=test_func, nrep=250, param_list=param_list, ncpus=1)
#' str(erg)
#'
#' rows<-c("n")
#' cols<-c("loc","scale")
#' MakeTable(output=erg, rows=rows, cols=cols, digits=2)
#'
#'
#' #-------- Further Examples: Compare Mean and Median as Estimators for the Expected Value
#'
#' # define func
#'
#' func<-function(n,loc,scale){
#'
#' # generate sample
#' sample<-rnorm(n, loc, scale)
#'
#' # calculate estimators
#' mean_sample<-mean(sample)
#' median_sample<-median(sample)
#'
#' # calculate bias
#' bias_mean_sample<-mean_sample-loc
#' bias_median_sample<-median_sample-loc
#'
#' # return results
#' return(list("mean for calculation of sd"=mean_sample,
#' "bias_mean"=bias_mean_sample,
#' "median for calculation of sd"=median_sample,
#' "bias_median"=bias_median_sample))
#' }
#'
#' n_grid<-c(50,100,250,500)
#' loc_grid<-seq(0,1,0.2)
#' scale_grid<-c(1,2)
#'
#' param_list=list("n"=n_grid, "loc"=loc_grid, "scale"=scale_grid)
#' erg_mean_median<-MonteCarlo(func=func, nrep=250, param_list=param_list, ncpus=1)
#'
#' rows<-c("n")
#' cols<-c("loc","scale")
#'
#' # use partial_grid
#'
#' MakeTable(output=erg_mean_median, rows=rows, cols=cols, digits=2,
#' partial_grid=list("n"=c(1,3), "loc"=c(1,3,5)), include_meta=FALSE)
#'
#' # use collapse to calculate standard deviation and bias
#'
#' collapse<-list("sd", "mean", "sd", "mean")
#' MakeTable(output=erg_mean_median, rows=rows, cols=cols, digits=2,
#' collapse=collapse, include_meta=FALSE)
#'
#' # merge all results in one table
#'
#' MakeTable(output=erg_mean_median, rows=c("n","loc"), cols=c("scale","list"),
#' digits=2, collapse=collapse, include_meta=FALSE)
#'
#' # transform the results for better scaling
#'
#' scale_table_10<-function(x){x*10}
#'
#' MakeTable(output=erg_mean_median, rows=c("n","loc"), cols=c("scale","list"),
#' digits=2, collapse=collapse,
#' transform=list(scale_table_10, NULL, function(x){x*10}, NULL),
#' include_meta=FALSE)
#'
#'@export
MakeTable<-function(output, rows, cols, digits=4, collapse=NULL, transform=NULL, include_meta=TRUE, width_mult=1, partial_grid=NULL){
if(class(output)!="MonteCarlo")stop("output has to be an object of class MonteCarlo.")
if(is.null(collapse)==FALSE){
for(i in 1:length(collapse)){
if(length(do.call(collapse[[i]], list(seq(1,10,1))))>1)stop("Functions included in collapse have to return a scalar.")
}
}
full_output_object<-output
param_list<-output$param_list
output<-output$results
if(is.null(partial_grid)==FALSE){
sel<-partial_grid
#param_list_new<-list()
sel_dims<-which(names(param_list)%in%names(sel))
for(i in 1:length(sel_dims)){
param_list[[sel_dims[i]]]<-param_list[[sel_dims[i]]][sel[[i]]]
}
}
for(i in 1:length(param_list)){
assign(paste(names(param_list)[i],"_grid",sep=""),param_list[[i]])
}
if(any(rows%in%cols))stop("Names in rows and cols must be unique.")
helpnames<-c(rows,cols)%in%c(names(param_list),"list")
if(any(helpnames==FALSE))stop(paste("The parameter", c(rows,cols)[which(helpnames==FALSE)],"is not part of param_list."))
if(is.null(collapse)){
collapse<-list()
for(i in 1:length(output)){collapse[[i]]<-"mean"}
}
output<-collapse_results(output, collapse=collapse) # from raw output average over results, so that monte carlo results are saved in list of large arrays
# apply function(s) passed through transform to output
if(is.null(transform)==FALSE){
if(any(c(is.function(transform), is.list(transform)))==FALSE)stop("transform must be either NULL, a function or a list of functions!")
if(is.list(transform)){if(length(transform)!=length(output))stop("List supplied as transform must be of the same lengths as output.")}
if(length(transform)==1){ # if only a single function is passed to MakeTable apply it to each array in collapsed output list
help<-list()
for(i in 1:length(output)){help[[i]]<-transform} # convert transform to list of functions that repeats the function transform
transform<-help
}
for(i in 1:length(output)){
if(is.null(transform[[i]])==FALSE){output[[i]]<-transform[[i]](output[[i]])} # apply i-th element of function list to i-th output array
}
}
# turn list elements in additional array dimensions if "list" is included in "rows" or "cols"
output_aux<-NULL
if("list"%in%unique(c(rows,cols))){
for(i in 1:length(output)){
output_aux<-abind(output_aux, output[[i]], along=(length(dim(output[[1]]))+1))
}
dimnames_aux<-dimnames(output[[1]])
dimnames_aux[[(length(dim(output[[1]]))+1)]]<-paste("list=",names(output), sep="")
dimnames(output_aux)<-dimnames_aux
list_grid<-names(output)
param_list$list<-list_grid
output<-list(output_aux)
names(output)<-paste(param_list$list,collapse=", ")
}
#### ----------------------------------------------------------------------------------- ###
for(lll in 1:length(output)){ # iterate over list elements to create own table for each variable returned by function fun
out<-output[[lll]] # select element from list
if(is.null(partial_grid)==FALSE){
sel<-partial_grid
array_selector<-rep("",length(dim(output[[1]])))
for(i in 1:length(sel_dims)){
array_selector[sel_dims[i]]<-paste("c(",paste(sel[[i]], collapse=","),")", collapse="")
}
array_selector<-paste("[", paste(array_selector, collapse=","),"]", collapse="")
eval(parse(text=paste("out<-out", array_selector, sep="")))
}
if(length(dim(out))==1){
if(is.null(rows)){
aux_dimnames<-list()
aux_dimnames[[1]]<-""
aux_dimnames[[2]]<-dimnames(out)[[1]]
out<-array(out, dim=c(1,dim(out)))
}
if(is.null(cols)){
aux_dimnames<-list()
aux_dimnames[[1]]<-dimnames(out)[[1]]
aux_dimnames[[2]]<-""
out<-array(out, dim=c(dim(out),1))
}
dimnames(out)<-aux_dimnames
}
## drop all dimensions from out-array that are equal to 1 (and thus unneccesary) and pass parameter information to description
pass_to_info<-NULL
if(length(dim(out))>2){
if(any(dim(out)==1)){
select<-which(dim(out)==1)
#------------ Make Sure that there is always at least one element in rows and cols ---------------#
if(all(rows%in%names(param_list)[select])){
select<-select[-1]
warning("All parameter grids in rows have only one element. Therefore they are superfluous.")
}
if(all(cols%in%names(param_list)[select])){
select<-select[-1]
warning("All parameter grids in cols have only one element. Therefore they are superfluous.")
}
#-----------------------------------------------------------------------------------------------------------#
if(length(select)>0){
pass_to_info<-as.character(dimnames(out)[select]) # add parameter info about dropped dimensions to caption
dims<-dim(out)
n_dims<-length(dims)
sel_str<-"out<-array(out["
for(i in 1:n_dims){
sel_str<-c(sel_str,if(i<n_dims){if(dims[i]==1){"1,"}else{","}}else{if(dims[i]==1){"1"}else{""}})
}
eval(parse(text=paste(c(sel_str,"], dim=dims[-select], dimnames=dimnames(out)[-select])"), collapse="")))
p_name<-unlist(strsplit(pass_to_info, split="="))[-(1:length(select))*2]
if(any(p_name%in%rows)){rows<-rows[-which(rows%in%p_name)]}
if(any(p_name%in%cols)){cols<-cols[-which(cols%in%p_name)]}
}
}
}
### escape special characters
pass_to_info<-gsub(pattern="_", replacement=paste("\\\\", "_", sep=""), pass_to_info)
###
#----- replace this part with helper function
dims<-dim(out)
n_dims<-length(dims)
all_names<-dimnames(out)
dim_names<-0
for(i in 1:(length(all_names))){dim_names[i]<-unlist(strsplit(all_names[[i]], split="="))[1]}
#----------------------------------------------------------------------------------------------#
if(any(na.omit(dim_names)%in%c(rows,cols)==FALSE))stop("rows and cols must contain all parameter names unless the grid has only one value.")
###--- rearrange array so that first dimension corresponds to first variable for row selected and
###--- second dimension has to correspond to first column selected
if(length(dim(out))>1){
sel<-c(which(dim_names==rows[1]),which(dim_names==cols[1]))
help_vec<-1:n_dims
perm<-c(sel,help_vec[-which(help_vec%in%sel)])
out<-aperm(out,perm=perm)
}
#----- replace this part with helper function
dims<-dim(out)
all_names<-dimnames(out)
dim_names<-0
for(i in 1:length(all_names)){dim_names[i]<-unlist(strsplit(all_names[[i]], split="="))[1]}
#----------------------------------------------------------------------------------------------#
###------------ construct index for interation over dimensions of out
###------------ make vectors that contain grid lengths for all variables in rows and columns but the first in each
ind<-rep("NA",(n_dims))
col_dims<-row_dims<-NULL
if(length(rows)>1){
for(i in 2:length(rows)){
sel_row<-(which(dim_names==rows[i]))
ind[sel_row]<-paste("i",i-1, sep="")
row_dims<-c(row_dims,dims[sel_row]) # dim of array corresponds to length of grid
}}
if(length(cols)>1){
for(j in 2:length(cols)){
sel_col<-(which(dim_names==cols[j]))
ind[sel_col]<-paste("j",j-1, sep="")
col_dims<-c(col_dims,dims[sel_col])
}}
ind<-paste(ind[-c(1,2)], collapse=",") # ignore the first two dimensions since these are fixed
############# Construct loops to generate matrix in the order specified by rows and cols #################
loops_rows<-length(rows)-1 # determine number of loops for rows
loops_cols<-length(cols)-1 # determine number of loops for columns
## inner loop runs over rows. if one block is completed the outer grid combines block of rows to columns
## the elementary building block is the matrix consisting of the first two dimensions of out,
## that correspond to the first row and the first column specified by the user.
## between all rows of these matrices a row of NAs is added.
## when columns are combined in the outer loop, columns are also seperated using a column of NAs
if(length(dim(out))>2){
inner_cols<-NULL
build_string<-paste(c(
if(loops_cols>0){paste("for(j",loops_cols:1," in 1:","col_dims[",loops_cols:1,"]){", sep="")}else{""},
"inner_rows<-NULL;",
if(loops_rows>0){paste("for(i",loops_rows:1," in 1:","row_dims[",loops_rows:1,"]){", sep="")}else{""},
paste("inner_rows<-rbind(inner_rows,matrix(out[,,",ind,"],dims[1],dims[2]),rep(NA,dims[2]))"),
rep("}",loops_rows),
";",
"inner_cols<-cbind(inner_cols,inner_rows,rep(NA,dims[1]+1))",
rep("}",loops_cols)), collapse="")
eval(parse(text=build_string))
erg_mat<-(inner_cols)
}else{
erg_mat<-rbind(cbind(out,NA),NA)
}
###------ for better readability add column of NAs between blocks for each grid value of the third column variable
if(length(cols)>2){
count_col<-dims[2]*col_dims[1]+col_dims[1]
rep_col<-dim(erg_mat)[2]/count_col
startstop_col<-matrix(NA,rep_col,2)
for(i in 1:rep_col){
startstop_col[i,]<-c((i-1)*count_col+1,i*count_col)
}
erg_mat2<-matrix(NA,nrow(erg_mat),ncol(erg_mat)+rep_col)
for(i in 1:rep_col){
erg_mat2[,((startstop_col[i,1]+(i-1)):(startstop_col[i,2]+(i-1)))]<-erg_mat[,(startstop_col[i,1]:startstop_col[i,2])]
}
erg_mat<-erg_mat2
}
###------ for better readability add row of NAs between blocks for each grid value of the third row variable
if(length(rows)>2){
count_row<-dims[1]*row_dims[1]+row_dims[1]
rep_row<-dim(erg_mat)[1]/count_row
startstop_row<-matrix(NA,rep_row,2)
for(i in 1:rep_row){startstop_row[i,]<-c((i-1)*count_row+1,i*count_row)}
erg_mat3<-matrix(NA,nrow(erg_mat)+rep_row,ncol(erg_mat))
for(i in 1:rep_row){
erg_mat3[((startstop_row[i,1]+(i-1)):(startstop_row[i,2]+(i-1))),]<-erg_mat[(startstop_row[i,1]:startstop_row[i,2]),]
}
erg_mat<-erg_mat3
}
############################################################
# Note that descriptions for rows and columns are handled differently due to the different behaviour of
# multicolumn and multirow in LaTeX. since multirow fits in one column, the descriptions for the rows can
# simply be included in the matrix that is supposed to be printed later.
# multicolumn on the other hand requires the omission of "&"s, so that they fit into LaTeX array. headers for
# the columns are therefore collected in seperate list
heads<-list()
# inner header
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
if(length(cols)>1){
help_head1<-eval(parse(text=paste("rep(c(paste(",paste(cols[1],"_grid",sep=""),"),NA),col_dims[1])",sep="")))
head1<-rep(c(help_head1,if(length(cols)>2){NA}else{NULL}),prod(col_dims[-1]))
}else{
if(is.null(cols)){head1<-c("",NA)}else{head1<-c(paste(get(paste(cols[1],"_grid",sep=""))),NA)
}
}
heads[[1]]<-head1
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# inner rownames
if(length(rows)>1){
help_rows1<-eval(parse(text=paste("rep(c(paste(",paste(rows[1],"_grid",sep=""),"),NA),row_dims[1])",sep="")))
}else{
if(is.null(rows)){help_rows1<-c("",NA)
}else{
help_rows1<-eval(parse(text=paste("rep(c(paste(",paste(rows[1],"_grid",sep=""),"),NA),1)",sep="")))
}
}
if(length(rows)>2){rows1<-rep(c(help_rows1,NA),prod(row_dims[-1]))}else{rows1<-help_rows1}
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# inner table with names
erg_mat4<-rbind(c(paste(rows[1],"/",cols[1], sep=""),NA,head1),rep(NA,length(head1)+2),cbind(rows1,rep(NA,length(rows1)),erg_mat))
dimnames(erg_mat4)<-NULL
erg_mat<-erg_mat4
################################################################################
##----------------------- In Case of multiple layers of rows or cols create additional headers ---------------##
## more than one layer of columns
if(length(cols)>1){
help_head2<-eval(parse(text=paste("paste('\\\\multicolumn{'",",","dims[2]",",","'}{c}{'",",",paste(cols[2],"_grid",sep=""),",","'}'",")")))
help_head2b<-rep(NA,2*col_dims[1]-1)
help_head2b[seq(1,length(help_head2b),2)]<-help_head2
if(length(col_dims[-1])>0){
head2<-rep(c(help_head2b,rep(NA,2)),prod(col_dims[-1]))}else{head2<-help_head2b}
heads[[2]]<-head2
}
n_multicol<-c(1,dims[2])
## more than two layers of columns
if(length(cols)>2){
for(i in 3:length(cols)){
col_mult<-if(i==3){1}else{2}
n_multicol[i]<-(n_multicol[(i-1)]+col_mult)*col_dims[(i-2)]-col_mult
assign(paste("help_head",i,sep=""),eval(parse(text=paste("paste('\\\\multicolumn{'",",","paste(n_multicol[i])",",","'}{c}{'",",",paste(cols[i],"_grid",sep=""),",","'}'",")",sep=""))))
assign(paste("head",i,sep=""),NULL)
eval(parse(text=paste("for(j in 1:length(",paste("help_head",i,sep=""),")){",paste("head",i,sep=""),"<-c(",paste("head",i,sep=""),",",paste("help_head",i,"[j]",sep=""),",NA,NA)}")))
heads[[i]]<-rep(get(paste("head",i,sep="")),prod(col_dims[-(1:(i-1))]))
}
}
## more than one layer of rows
if(length(rows)>1){
help_rows2<-eval(parse(text=paste("paste('\\\\multirow{'",",","dims[1]",",","'}{*}{'",",",paste(rows[2],"_grid",sep=""),",","'}'",")")))
help_rows2b<-rep(NA,length(help_rows2)*(dims[1]+1))
help_rows2b[seq(1,length(help_rows2b),dims[1]+1)]<-help_rows2
if(length(rows)>2){
rows2<-c(rows[2],NA,rep(c(help_rows2b,NA),prod(row_dims[-1])))
}else{
rows2<-c(rows[2],NA,help_rows2b)
}
}
n_multirow<-c(1,dims[1])
## more than two layers of rows
if(length(rows)>2){
for(i in 3:length(rows)){
row_mult<-if(i==3){1}else{2}
n_multirow[i]<-(n_multirow[(i-1)]+row_mult)*row_dims[(i-2)]-row_mult
assign(paste("help_rows",i,sep=""),eval(parse(text=paste("paste('\\\\multirow{'",",","paste(n_multirow[i])",",","'}{*}{'",",",paste(rows[i],"_grid",sep=""),",","'}'",")",sep=""))))
assign(paste("rows_help",i,sep=""),NULL)
eval(parse(text=
paste("for(j in 1:",
paste(length(get(paste("help_rows",i,sep="")))),"){",
paste("rows_help",i,sep=""),"<-c(",
paste("rows_help",i,sep=""),",",
paste("help_rows",i,"[j],",sep=""),
paste(paste(paste(rep(NA,n_multirow[i]+1)),collapse=","),")}",collapse=""))
))
assign(paste("rows",i,sep=""),c(rows[i],NA,rep(get(paste("rows_help",i,sep="")),prod(row_dims[-(1:(i-1))]))))
}
}
##---------------------------------------------------------------------------------##
erg_mat5<-erg_mat
if(length(rows)>1){for(i in 2:length(rows)){erg_mat5<-cbind(get(paste("rows",i, sep="")),erg_mat5)}}
drop_col<-NULL
for(i in 1:ncol(erg_mat5)){if(sum(is.na(erg_mat5[,ncol(erg_mat5)+1-i])==FALSE)==0){drop_col<-c(drop_col,i)}else{break}}
drop_row<-NULL
for(i in 1:nrow(erg_mat5)){if(sum(is.na(erg_mat5[nrow(erg_mat5)+1-i,])==FALSE)==0){drop_row<-c(drop_row,i)}else{break}}
erg_mat6<-erg_mat5[-c(nrow(erg_mat5)+1-drop_row),-c(ncol(erg_mat5)+1-drop_col)]
erg_mat7<-matrix("&",nrow(erg_mat6),ncol(erg_mat6)*2-1)
###------ reformat results so that the output is printed with specified number of digits
aux<-erg_mat6[-c(1,2),-c(1:length(rows))]
sel<-which(is.na(aux)==FALSE)
aux[sel]<-format(round(as.numeric(as.vector(aux)[sel]),digits=digits), nsmall=digits, scientific=FALSE)
erg_mat6[-c(1,2),-c(1:length(rows))]<-aux
#########
erg_mat7[,seq(1,ncol(erg_mat7),2)]<-erg_mat6
erg_mat7[which(is.na(erg_mat7))]<-""
###------ Define all character strings needed for header and footer of the table in vectors ########
preamble<-c("\\begin{table}[h]","\n",
"\\centering","\n",
paste("\\resizebox{",width_mult,"\\textwidth}{!}{%", collapse=""),"\n",
paste("\\begin{tabular}{",paste(rep("r",((ncol(erg_mat7)-1)/2+1)), collapse=""),"}"),"\n",
"\\hline","\\hline","\\\\","\\\\","\n")
footer<-c("\\\\","\n","\\\\","\n","\\hline","\\hline","\n",
"\\end{tabular}%","\n",
"}","\n",
paste("\\caption{",gsub(pattern="_", replacement=paste("\\\\","_", sep=""), names(output)[lll]),
if(is.null(pass_to_info)==FALSE){paste(pass_to_info, collapse=",")}else{""},"}")
,"\n",
"\\end{table}", "\n")
for(i in 1:length(heads)){
help<-rep("&",length(heads[[i]])*2-1) # include "&" inbetween elements in header to seperate columns of table in LaTeX
help[seq(1,length(help),2)]<-heads[[i]]
heads[[i]]<-help
heads[[i]][which(is.na(heads[[i]]))]<-"" # replace all NA values with whitespace
heads[[i]]<-gsub(pattern="_", replacement=paste("\\\\","_", sep=""), heads[[i]])
}
###------ escape underscore in variable names
erg_mat7<-gsub(pattern="_", replacement=paste("\\\\","_", sep=""), erg_mat7)
cols<-gsub(pattern="_", replacement=paste("\\\\","_", sep=""), cols)
###-------------------- Loops to print the table from its elements using cat -------------------###
for(i in 1:length(heads)){
while(heads[[i]][length(heads[[i]])]==""){
heads[[i]]<-heads[[i]][1:(length(heads[[i]])-2)]
}
}
for(i in 1:length(preamble)){cat(preamble[i])}
if(length(cols)>1){
for(i in 1:(length(heads)-1)){
cat(rep("&",length(rows)-1),paste(cols[length(heads)+1-i]),"&&",heads[[length(heads)+1-i]],"\\\\","\n")
}}
for(i in 1:nrow(erg_mat7)){cat(erg_mat7[i,],"\\\\","\n")}
for(i in 1:length(footer)){cat(footer[i])}
if(length(output)>lll){cat("\n","\n","\n")}
###------------------------------------------------------------------------------------------------###
} # finish loop over all list elements in output of MonteCarlo()
###-------- Print information provided by summary.MonteCarlo(output) in comments below table.
if(include_meta==TRUE){
cat("%\n")
if(is.null(transform)){cat("% transform = NULL","\n")}else{cat("% transform: ",paste(unlist(transform), collapse=", "),"\n")}
cat("% collapse: ", paste(unlist(collapse), collapse=", "),"\n")
summ_out<-capture.output(summary(full_output_object))
cat("%","\n")
for(i in 1:length(summ_out)){
cat("% ",summ_out[[i]],"\n")
}
}
###---------------------------------------
# End function.
}
#######################################################################################################################################
Try the MonteCarlo 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.