MakeTable.R

#############################################################################
###                        --- Functions ---                              ###
#############################################################################

# Combine Tables als Funktion in Paket aufnehmen oder lieber herzeigen wie do.call(rbind,tables) geht...?
# CombineTables <- function(tables){
#   
#   if(!is.null(names(tables))){
#     for(i in 1:length(tables)){
#       if(names(tables)[i]!="")
#         rownames(tables[[i]])[1] <- names(tables)[i]
#     }
#   }
#   do.call(rbind,tables)
# }

parameterSpellCheck <- function(x){
  y <- unlist(x)
  p <- c("TFstring","TFstring2","each","fun","var","Total","Mean", "Median", "GroupSize","GroupRate","scaleF")
  
  if(!all(sapply(p,function(q) identical(grep(q,names(y),ignore.case=FALSE),grep(q,names(y),ignore.case=TRUE))))){
    
    warning("\n\nFailed Spell-Check! \nEin Parameter wurde moeglicherweise falsch geschrieben (Achtung: Case Sensitivity), das kann zu einem Abbruch der Funktion fuehren.\n",
            "\nBitte ueberpruefe Parameter '",paste0(p[!sapply(p,function(q) identical(grep(q,names(y),ignore.case=FALSE),grep(q,names(y),ignore.case=TRUE)))],collapse="' und '"),"'\n")
  }
}
makeEachVar <- function(x){
  x <- x[length(x):1]
  res <- 0
  for(i in 1:length(x)){
    res <- res + x[i]*10^((i-1)*3)
  }
  return(res)
}

# estimator: est,estPrev,absChange,relChan
#' Funktion zur Erstellung von Tabellen in Matrix-Form.
#' 
#' Erstellt eine Tabelle in Matrix-Form.
#' 
#' \strong{col}
#' 
#' Die Syntax fuer Spalten, Zeilen und Block Listen \code{col} ist eine aus
#' Sublisten bestehende Liste. Jede Subliste steht fuer eine eigene Spalte der
#' zu erstellenden Tabelle in Matrix-Form und gibt an, was fuer die
#' entsprechende Spalte berechnet werden soll. Jede Subliste kann die Argumente
#' \code{fun}, \code{TFstring}, \code{TFstring2}, \code{digits}, \code{var} und
#' \code{scaleF} enthalten. \code{fun} muss dabei gesetzt werden und zwar auf
#' eine der vier Funktionen \code{GroupSize}, \code{GroupRate}, \code{Mean},
#' \code{Total} und \code{Median} aus dem mzR-Paket, die restlichen Parameter sind optional.
#' \code{TFstring}, \code{TFstring2}, \code{digits} und \code{var} sind einfach
#' die Parameter aus eben genannten Funktionen, \code{scaleF} ist der
#' Skalierungsfaktor der auf die jeweilige Spalte angewendet werden soll, also
#' z.B. \code{scaleF="/1000"} gibt an, dass die Ergebnisse der entsprechenden
#' Spalte durch 1000 dividiert werden sollen, er ist als character zu
#' uebergeben.
#' 
#' \strong{row}
#' 
#' \code{row} ist eine 'list', 'named list' oder 'partly named list' die
#' Sublisten enthalten kann aber nicht muss. Sublisten werden eigentlich nur
#' uebergeben, wenn einem Element aus \code{row} mehr als ein Parameter
#' zugewiesen werden soll. Zusaetzlich zu den moeglichen Argumenten fuer
#' \code{col} (ausser \code{digits}) kann hier auch noch \code{each} gesetzt
#' werden (auch ein Parameter aus den mzR-Schaetz-und
#' Fehlerrechnungsfunktionen), \code{fun} ist hier prinzipiell optional, muss 
#' aber in vielen Faellen fuer einen sinnvollen Output angegeben werden. 
#' Will man beispielsweise einen Mittelwert berechnen, so wuerde das dementsprechende 
#' \code{row} Sublistenelement z.B. folgendermassen aussehen: 
#' \code{list(fun="Mean",var="VarName",TFstring="!is.na(VarName)",scaleF="*1")},
#' d.h. es wird in der entsprechenden Zeile der Tabelle jeweils der Mittelwert
#' der Variable VarName berechnet, zusaetzlich dazu werden aber ueber den \code{TFstring} 
#' auch noch die fehlenden Werte in der Variable VarName ausgeschlossen.
#' Wird der Parameter
#' \code{scaleF} bei \code{row} gesetzt, so hat er den Vorzug vor \code{scaleF}
#' bei \code{col} - sollte er dort gesetzt worden sein (hier nicht vergessen,
#' falls in \code{row} Raten berechnet werden sollen \code{scaleF="*1"}
#' setzen). Falls \code{GroupRate}, \code{Mean}, \code{Total} oder \code{Median} sowohl in 
#' \code{row} als auch \code{col} gesetzt wurden wird fuer die jeweilige Zelle 
#' im Output kein Ergebnis ausgegeben.
#' 
#' \strong{block}
#' 
#' \code{block} ist eine Liste, die gewisse Einschraenkungen (oder \code{NULL},
#' falls keine Einschraenkung gemacht werden soll) enthaelt, welche jeweils
#' fuer alle Zeilen ausgefuehrt werden sollen. Diese Einschraenkungen werden
#' pro \code{block}-Element fuer alle \code{row}-Elemente ausgefuehrt. D.h. es
#' kann z.B. eine Output-Tabelle erstellt werden die im ersten 'Block' die
#' Ergebnisse fuer Schnecken und im zweiten Block die Ergebnisse fuer
#' Nicht-Schnecken enthaelt.
#' 
#' Kleine Bemerkung am Rande: Fuer die meisten Publikationen ist es sinnvoll, 
#' keine \code{digits} bei \code{col} bei \code{MakeTable()} zu setzen da oft die vorgegebenen
#' Excel-Formate das Runden uebernehmen.
#' 
#' @param dat MZ Daten - Output von Funktion \link{ImportData}.
#' @param col Listenobjekt um Spalten zu definieren, siehe Details.
#' @param row Listenobjekt oder NULL um Zeilen zu definieren, siehe Details.
#' @param block Listenobjekt oder NULL um Block-Output definieren, siehe
#' Details.
#' @param estimator character um festzulegen, welcher Schaetzer in die Tabelle
#' kommen soll. Auwahlmoeglichkeiten sind \code{"est"}, \code{"estPrev"},
#' \code{"absChange"} und \code{"relChange"}.
#' @param error character um festzulegen, welcher Genauigkeitsschaetzer zur Markierung von Zellen verwendet werden soll. 
#' Auswahlmoeglichkeiten sind \code{"cv"} (Variationskoeffizient) und \code{"ci"} (Konfidenzintervall). 
#' Sollte \code{error="cv"} gewaehlt werden, so sind die Parameter \code{lim1} bzw. \code{lim2} gegebenenfalls zu spezifizieren. 
#' Falls jedoch \code{error="ci"} gewaehlt wird, so sind diese Limits nicht notwendig, da in diesem Fall untersucht wird, 
#' ob der Schaetzer nicht-signifikant ist, ob also das jeweilige Konfidenzintervall den Wert 0 enthaelt. 
#' Man kann jedoch \code{markLeft1}, \code{markRight1} und \code{markValue1}
#' spezifizieren, falls die nicht-signifikanten Zellen anders als durch die Defaulteinstellung 
#' \code{markLeft1 = "("}, \code{markRight1 = ")"} und \code{markValue1 = NULL} markiert werden sollen.
#' @param lim1 numerischer Wert: falls \code{lim1}>\code{error}, wird der
#' entsprechende Wert von \code{estimator} in der Tabelle durch
#' \code{markLeft1}, \code{markValue1} und \code{markRight1} ersetzt. Ist nur relevant falls code{error="cv"}.
#' @param markValue1 character oder NULL: falls NULL, wird der jeweilige Wert
#' von \code{estimator} nicht ueberschrieben.
#' @param markLeft1 character: wird links zu \code{markValue1} hinzugefuegt.
#' @param markRight1 character: wird rechts zu \code{markValue1} hinzugefuegt.
#' @param lim2 numerischer Wert: falls \code{lim2}>\code{error}, wird der
#' entsprechende Wert von \code{estimator} in der Tabelle durch
#' \code{markLeft2}, \code{markValue2} und \code{markRight2} ersetzt. Ist nur relevant falls code{error="cv"}.
#' @param markValue2 character oder NULL: falls NULL, wird der jeweilige Wert
#' von \code{estimator} nicht ueberschrieben. Ist nur relevant falls code{error="cv"}.
#' @param markLeft2 character: wird links zu \code{markValue2} hinzugefuegt. Ist nur relevant falls code{error="cv"}.
#' @param markRight2 character: wird rechts zu \code{markValue2} hinzugefuegt. Ist nur relevant falls code{error="cv"}.
#' @param rowPriority TRUE/FALSE ob bei der Berechnung von Raten die Zeilenlogik vor der Spaltenlogik gelten soll.
#' @param returnCommands TRUE/FALSE ob statt einer Tabelle die Befehle
#' ausgegeben werden sollen die zur Erstellung der Tabelle ausgefuehrt werden
#' wuerden.
#' @return Output ist eine Tabelle in Matrix-Form mit durch \code{col},
#' \code{row} und \code{block} definierten Spalten und Zeilen.
#' @seealso
#' \code{\link{FillExcelTemplate},\link{MakeQT},\link{ImportDataListQT},\link{ImportData},\link{IndivImportData},\link{ImportAndMerge}}
#' @export
#' @examples
#' \dontrun{
#' 
#' dat <- ImportData(year=2014,quarter=4,comp_diff_lag = 1)
#' ### Spalten definieren
#' col <- list()
#' col[[length(col)+1]] <- list(fun="GroupSize",TFstring="balt>=15&balt<=74",
#'                              digits=3, scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupSize",TFstring="balt>=15&balt<=25",
#'                             digits=3, scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupRate",TFstring="balt>=15&balt<=25", 
#'                              TFstring2="balt>=15&balt<=74", digits=3)
#' col[[length(col)+1]] <- list(fun="GroupRate",
#'                              TFstring="xerwstat==1&balt>=15&balt<=74", 
#'                              TFstring2="xerwstat%in%c(1,2)&balt>=15&balt<=74", digits=3)
#' col[[length(col)+1]] <- list(fun="Total",
#'                              TFstring="xerwstat==1&balt>=15&balt<=74",var="dtstd",
#'                              digits=3, scaleF="/24/365")
#' ### Zeilen definieren
#' row <- list(
#'   NULL,
#'   each="xnuts2",
#'   list(TFstring="bpras!=1 & balt>=15 & balt<=64", scaleF="*1"),
#'   each="rbpkin+xbstaat",
#'   TFstring="balt>=15&balt<=25"
#' )
#'
#' ### Bloecke definieren
#' block <- list(NULL, "bsex==1", "bsex==2")
#'
#' ### Erstellen 3 Tabellen fuer FillExcelTemplate(), jeweils mit verschiedenen Regeln 
#' ##  zur Kennzeichnung von bestimmten Werten
#' ##  Achtung: kann durchaus laenger dauern!
#'
#' ### 1. Tabelle mit Limits (bezogen auf Variationskoeffizient)
#' tab1 <- MakeTable(dat, col=col, row=row, block=block, error="cv", 
#'                  lim1=0.17, lim2=0.25)
#' ### 2. Tabelle ohne Limits und Default-Error-Einstellung liefert unmarkierte Zellen-Werte
#' tab2 <- MakeTable(dat, col=col, row=row, block=block) 
#'
#' ### 3. Tabelle der relativen Veraenderungen vom 3. Quartal 2014 aufs 4. Quartal 2014 
#' ##  Nicht-signifikante Schaetzwerte (Konfidenzintervall enthaelt den Wert 0) 
#' ##  werden durch * markiert.
#' ##  Achtung: bei einigen col-Listenelementen wurde scaleF spezifiziert. 
#' ##  Das macht hier fuer Veraenderungen keinen Sinn, wird aber der Einfachheit halber 
#' ##  fuer dieses Beispiel so belassen.
#' tab3 <- MakeTable(dat, col=col, row=row, block=block, estimator="relChange", error="ci",
#'                   markLeft1="",markRight1="*",markValue1=NULL) 
#'
#' 
#' ### Commands ansehen fuer tab1
#' tab1_commands <- MakeTable(dat,col=col,row=row, block=block,error="cv", 
#'   lim1=0.17,lim2=0.25,returnCommands=TRUE)
#' ## -> Bsp: block 1, col 3, row 4: 
#' tab1_commands[[1]][[3]][[4]]
#' 
#' }
MakeTable  <- function(dat,col,row=NULL,block=NULL,estimator="est",error="cv",
                       lim1=Inf,markLeft1="(",markRight1=")",markValue1=NULL,
                       lim2=Inf,markLeft2="(",markRight2=")",markValue2="x",
                       rowPriority=TRUE, returnCommands=FALSE){
  #emptyRows=FALSE, 
  parameterSpellCheck(row)
  parameterSpellCheck(col)
  
  # Bei Veraenderungen wollen wir ein weniger strenges Mass als den Variationskoeffizienten.
  # Es wird also nur geschaut, ob der geschaetzte Wert innerhalb des Konfidenzintervalls liegt.
  if(error=="ci"){
    error <- "cil"
    lim1 <- 1
    lim2 <- Inf
  }
  if(estimator=="absChange"){
    error <- paste0(error,toupper(substr(estimator,1,1)), substr(estimator,start=2,stop=nchar(estimator)))
  }else if(estimator=="relChange"){
    error <- paste0(error,toupper(substr(estimator,1,1)), substr(estimator,start=2,stop=nchar(estimator)))
  } else if(estimator=="estPrev"){
    error <- paste0(error,"Prev")
  }
  if(any(unlist(lapply(col,function(x)is.null(x$fun)))))
    stop("col in MakeTable() muss immer einen Parameter 'fun' enthalten!")
  
  
  ##eigentlich brauch ich diese each-Aufspragelung nur wenn GroupRates oder sowas berechnet werden sollen...
  if((any(grepl("each",row)) || any(grepl("each",names(row))))){# && rowPriority){
    if(returnCommands){
      warnings("\nAchtung, 'each' aus 'row' wird aufgesplittet in mehrere TFstrings. Bei returnCommands-Output beachten!\n")
    }
    while(any(grepl("each",row))){
      eachind <- grep("each",row)[1] #row wird ja ueberschrieben
      each <- row[[eachind]]$each
      eachrow_orig <- row[[eachind]]
      ##############
      if(length(grep("\\+",each))>0){
        eachv <- strsplit(each,"\\+")[[1]]
        eachvar <- paste(eachv,collapse="_")
        for(i in 1:length(dat)){
          dat[[i]][[eachvar]] <- apply(dat[[i]][,eachv,with=FALSE],1,makeEachVar)
        }
      }else{
        eachv <- eachvar <- each
      }
      TFstringeach <- vector()
      for(l in dat[[1]][,sort(unique(eval(parse(text=eachvar))))]){
        TFstringeach[length(TFstringeach)+1] <- paste0(eachvar,"==",l)
      }  
      #############
      eachlist <- list()
      for(e in 1:length(TFstringeach)){
        eachlist[[length(eachlist)+1]] <- eachrow_orig
        eachlist[[e]][["each"]] <- NULL 
        if(!is.null(eachlist[[e]][["TFstring"]])){
          eachlist[[e]][["TFstring"]] <- paste0(c(eachlist[[e]][["TFstring"]],TFstringeach[e]),collapse=" & ")
        }else{
          eachlist[[e]][["TFstring"]] <- TFstringeach[e]  
        }
      }
      row[[eachind]]<-NULL
      row <- append(row,eachlist,after=eachind-1)
      
    }
    while(any(grepl("each",names(row)))){
      eachind <- grep("each",names(row))[1] #row wird ja ueberschrieben
      each <- row[[eachind]]
      ##############
      if(length(grep("\\+",each))>0){
        eachv <- strsplit(each,"\\+")[[1]]
        eachvar <- paste(eachv,collapse="_")
        for(i in 1:length(dat)){
          dat[[i]][[eachvar]] <- apply(dat[[i]][,eachv,with=FALSE],1,makeEachVar)
        }
      }else{
        eachv <- eachvar <- each
      }
      TFstringeach <- vector()
      for(l in dat[[1]][,sort(unique(eval(parse(text=eachvar))))]){
        TFstringeach[length(TFstringeach)+1] <- paste0(eachvar,"==",l)
      }  
      #############
      eachlist <- list()
      for(e in 1:length(TFstringeach)){
        eachlist[[length(eachlist)+1]] <- TFstringeach[e]
        names(eachlist)[length(eachlist)] <- "TFstring"
      }
      row[[eachind]]<-NULL
      row <- append(row,eachlist,after=eachind-1)
    }
  }
  
  
  if(!is.null(block)){
    save.dat <- copy(dat)  
    outlist <- list()
    outcmd_list <- list()
  }
  
  leBlock <- ifelse(length(block)>0,length(block),1)
  
  
  for(i in 1:leBlock){
    
    if(!is.null(block[[i]])){
      dat <- lapply(dat,function(x)x[eval(parse(text=block[[i]])),])
    }
    
    out <- lapply(col,function(colx){
      
      if(returnCommands){
        cmd_list <- list()
      }
      out <- list()
      novaluelist <- list()
      
      colcommands <- colx[-which(names(colx)%in%c("fun","digits","scaleF"))]
      if(length(colcommands)==0){
        colcommands <- list(TFstring=NULL)
      }
      origcolcommands <-  colcommands
      
      whichcol <- which(sapply(col,function(z)isTRUE(all.equal(colx,z))))
      
      nrow <- length(row)
      if(nrow==0)
        nrow <- 1
      
      colx.orig <- colx
      row.orig <- row
      
      ###vielleicht fuer showCommands so eine Art j_orig einfuehren....?
      
      for(j in 1:nrow){
        
        ## Alle row-commands auf ein Format bringen, also in Listenform
        if(!is.list(row[[j]]) && !is.null(row[[j]])){
          rowcommands <- eval(parse(text=paste0("list(",names(row)[j],"=\"",row[[j]],"\")")))
        }else if(is.null(row[[j]])){
          rowcommands  <- list(NULL) 
        }else{
          rowcommands <- row[[j]]
        }
        cellcommands <- list()
        
        if(is.null(unlist(rowcommands))){##hier einfach als TFstring=NULL herrichten
          names(rowcommands) <- "TFstring"
        }
        ## zuerst args fertig herrichten, dann erst zu commands machen
        #if(!is.null(unlist(rowcommands))){#else Fall: args bleiben args, ausser bei rowPriority=TRUE
        
        ## Einige Plaus-Schritte
        if("TFstring2"%in%names(rowcommands)){
          row[[j]][["fun"]] <- "GroupRate"##evt hier noch warning einbauen fall orig row fun nicht GroupRate war sondern was andres
          rowcommands[[length(rowcommands)+1]] <- "GroupRate"
          names(rowcommands)[length(rowcommands)] <- "fun"
        }
        if("TFstring"%in%names(rowcommands) && !"var"%in%names(rowcommands) && !"TFstring2"%in%names(rowcommands) && !names(rowcommands)%in%c("fun")){
          row[[j]][["fun"]] <- "GroupSize" #row Element NULL wird nicht hier behandelt sondern ueberhaupt extra...wahrscheinlich
          rowcommands[[length(rowcommands)+1]] <- "GroupSize"
          names(rowcommands)[length(rowcommands)] <- "fun"
        }
        # if("each"%in%names(rowcommands) && !"var"%in%names(rowcommands) && !"TFstring2"%in%names(rowcommands) && !names(rowcommands)%in%c("fun")){
        #   row[[j]][["fun"]] <- "GroupSize" #row Element NULL wird nicht hier behandelt sondern ueberhaupt extra...wahrscheinlich
        #   rowcommands[[length(rowcommands)+1]] <- "GroupSize"
        #   names(rowcommands)[length(rowcommands)] <- "fun"
        # }
        
        ## Funktion in row auf Funktion aus col setzen falls keine uebergeben wird und obiges nicht greift (kann das ueberhaupt noch vorkommen?)
        ## falls nein, kann man rowcommands zuweisungen in den obigen Schritten wieder loeschen
        if(all(!names(rowcommands)%in%c("fun"))){
          row[[j]][["fun"]] <- colx[["fun"]]             
        }
        ## rowcommands auf zulaessige Parameter einschraenken
        if(any(!names(rowcommands)%in%c("TFstring","TFstring2","var"))){  # ,"each"))){
          rowcommands <- rowcommands[-which(!names(rowcommands)%in%c("TFstring","TFstring2","var"))] # ,"each"))]
        }  
        
        ## novaluelist befuellen (warnings fehlen noch)
        estfuns <- c("GroupRate","Total","Mean", "Median")
        if((row[[j]][["fun"]] %in% estfuns && colx[["fun"]] %in% estfuns) || 
           (colx[["fun"]] %in% estfuns && isTRUE(row[[j]][["fun"]] %in% estfuns))){
          novaluelist[[length(novaluelist)+1]] <- c(row=j,col=whichcol)
        }
        
        # else if("var"%in%names(rowcommands) && !row[[j]][["fun"]]%in%c("Total","Mean")){#bei col MUSS ja Fkt uebergeben werden
        #   warning("var ",rowcommands[["var"]]," wird bei 'row ",j,", col ",whichcol, "' ignoriert da Funktion ",row[[j]][["fun"]]," ausgefuehrt wird. \n")
        # }## sollte schon dadurch abgefangen werden, dass bei fehlender fun einfach die Spaltenfun zugewiesen wird und somit kein Wert ausgegeben wird da dann z.B. MeanxMean
        
        ### Total und Mean-Zeug spaeter genauer machen 
        
        ## Nur relevant fuer GroupRate
        #GroupRate geht nur mit GroupSize!  
        
        if(colx[["fun"]]=="GroupRate" && row[[j]][["fun"]]=="GroupSize"){       
          if(rowPriority){
            cellcommands[[length(cellcommands)+1]] <- paste0(c(rowcommands[["TFstring"]],colcommands[["TFstring"]]),collapse=" & ")
            names(cellcommands)[length(cellcommands)] <- "TFstring"
            
            cellcommands[[length(cellcommands)+1]] <- paste0(c(rowcommands[["TFstring"]],colcommands[["TFstring2"]]),collapse=" & ")
            names(cellcommands)[length(cellcommands)] <- "TFstring2"
          }else{
            cellcommands[[length(cellcommands)+1]] <- paste0(c(rowcommands[["TFstring"]],colcommands[["TFstring"]]),collapse=" & ")#,colcommands[["TFstring2"]]#braucht man eh nicht, sollte eigentlich in rowcommands[["TFstring"]] drinstecken
            names(cellcommands)[length(cellcommands)] <- "TFstring"
            cellcommands[[length(cellcommands)+1]] <- paste0(c(colcommands[["TFstring"]]),collapse=" & ")#,colcommands[["TFstring2"]]
            names(cellcommands)[length(cellcommands)] <- "TFstring2"
          }
          cellcommands[[length(cellcommands)+1]] <- "GroupRate"
          names(cellcommands)[length(cellcommands)] <- "fun"
        }else if(colx[["fun"]]=="GroupSize" && row[[j]][["fun"]]=="GroupRate"){
          if(rowPriority){
            cellcommands[[length(cellcommands)+1]] <- paste0(c(rowcommands[["TFstring"]],colcommands[["TFstring"]]),collapse=" & ")
            names(cellcommands)[length(cellcommands)] <- "TFstring"
            
            cellcommands[[length(cellcommands)+1]] <- paste0(c(colcommands[["TFstring"]],rowcommands[["TFstring2"]]),collapse=" & ")
            names(cellcommands)[length(cellcommands)] <- "TFstring2"
          }else{
            cellcommands[[length(cellcommands)+1]] <- paste0(c(rowcommands[["TFstring"]]),colcommands[["TFstring"]],collapse=" & ")#,rowcommands[["TFstring2"]]#braucht man eh nicht, sollte eigentlich in colcommands[["TFstring"]] drinstecken
            names(cellcommands)[length(cellcommands)] <- "TFstring"
            cellcommands[[length(cellcommands)+1]] <- paste0(c(colcommands[["TFstring"]]),collapse=" & ")#,rowcommands[["TFstring2"]]
            names(cellcommands)[length(cellcommands)] <- "TFstring2"
          }
          cellcommands[[length(cellcommands)+1]] <- "GroupRate"
          names(cellcommands)[length(cellcommands)] <- "fun"
        }else if(row[[j]][["fun"]]!=colx[["fun"]] && (row[[j]][["fun"]]=="GroupSize" || colx[["fun"]]=="GroupSize") && row[[j]][["fun"]]!="GroupRate" && colx[["fun"]]!="GroupRate" ){#Alles zieht immer vor GroupSize, Rest geht nicht gemeinsam
          cellcommands[[length(cellcommands)+1]] <- paste0(c(colcommands[["TFstring"]],rowcommands[["TFstring"]]),collapse=" & ")
          names(cellcommands)[length(cellcommands)] <- "TFstring"
          ## Funktion bestimmen die dann ausgefuehrt werden soll
          if(row[[j]][["fun"]]=="GroupSize"){
            cellcommands[[length(cellcommands)+1]] <- colx[["fun"]]
            names(cellcommands)[length(cellcommands)] <- "fun"
          }else if(colx[["fun"]]=="GroupSize"){
            cellcommands[[length(cellcommands)+1]] <- row[[j]][["fun"]]
            names(cellcommands)[length(cellcommands)] <- "fun"
          }
        }else if(colx[["fun"]]=="GroupSize" && row[[j]][["fun"]]=="GroupSize"){###!!!insgesamt ACHTUNG bei ""-Zuweisungen statt NULL, noch was ueberlegen
          cellcommands[[length(cellcommands)+1]] <- paste0(c(colcommands[["TFstring"]],rowcommands[["TFstring"]]),collapse=" & ")
          names(cellcommands)[length(cellcommands)] <- "TFstring"
          cellcommands[[length(cellcommands)+1]] <- "GroupSize"
          names(cellcommands)[length(cellcommands)] <- "fun"
          # if(any(names(rowcommands)%in%"each")){
          #   cellcommands[[length(cellcommands)+1]] <- rowcommands[["each"]]
          #   names(cellcommands)[length(cellcommands)] <- "each"
          # }
        }else if(colx[["fun"]]=="GroupRate" && row[[j]][["fun"]]=="GroupRate"){ # GroupRatexGroupRate-Platzhalter-Wert -> Rechnen hier irgendwas aus, Ergebnis wird eh nicht angezeigt aber fuer unteren Schritt brauchen wir einen cv im Hintergrund
          cellcommands[[length(cellcommands)+1]] <- paste0(c(colcommands[["TFstring"]],rowcommands[["TFstring"]]),collapse=" & ")
          names(cellcommands)[length(cellcommands)] <- "TFstring"
          cellcommands[[length(cellcommands)+1]] <- "GroupSize"
          names(cellcommands)[length(cellcommands)] <- "fun"
        }
        
        # dann fehlen noch Mean und Total
        # 2xvar geht nicht weil z.B. MeanxMean nicht geht
        # ist also in so einem Fall wurscht und rowPriority auch egal weil Zelle sowieso nicht ausgegeben wird
        # MeanxGroupRate und so wird auch so abgefangen
        if(any(names(rowcommands)%in%"var")){
          cellcommands[[length(cellcommands)+1]] <- rowcommands[["var"]]##var=NULL moeglich?abfangen?
          names(cellcommands)[length(cellcommands)] <- "var"
          cellcommands[[length(cellcommands)+1]] <- row[[j]][["fun"]]
          names(cellcommands)[length(cellcommands)] <- "fun"
        }else if(any(names(colcommands)%in%"var")){
          cellcommands[[length(cellcommands)+1]] <- colcommands[["var"]]
          names(cellcommands)[length(cellcommands)] <- "var"
          cellcommands[[length(cellcommands)+1]] <- colx[["fun"]]
          names(cellcommands)[length(cellcommands)] <- "fun"
        }
        cellcommands <- lapply(cellcommands,function(x)if(x[[1]]=="")x[[1]] <- "NULLeinfuellen" else x[[1]] <-x[[1]])
        
        args <- cellcommands[!names(cellcommands)=="fun"]
        for(a in 1:length(cellcommands[!names(cellcommands)=="fun"])){
          args[a] <- paste0(names(cellcommands[!names(cellcommands)=="fun"])[a], "=\"", cellcommands[!names(cellcommands)=="fun"][[a]], "\"")
        }
        args <-  paste0(args, collapse=",")
        args <- gsub("\"NULLeinfuellen\"","NULL",args,fixed=TRUE)
        
        cmd <- paste0(cellcommands[["fun"]],"(dat,",args,")")
        
        cmd <- paste0("out[[j]] <- ",cmd)
        
        #rowname bestimmen:
        if(row[[j]][["fun"]]=="GroupSize"){
          if(!is.null(rowcommands[["TFstring"]])){
            cmd <- paste0(cmd,";names(out)[j]<-","\"",as.name(rowcommands[["TFstring"]]),"\"")
          }else{
            cmd <- paste0(cmd,";names(out)[j]<-\"\"")
          }        
        }else if(row[[j]][["fun"]]=="GroupRate"){
          cmd <- paste0(cmd,";names(out)[j]<-","\"","RATE","\"")
        }else if(row[[j]][["fun"]]=="Mean"){
          cmd <- paste0(cmd,";names(out)[j]<-","\"","MEAN","\"")
        }else if(row[[j]][["fun"]]=="Total"){
          cmd <- paste0(cmd,";names(out)[j]<-","\"","TOTAL","\"")
        }else if(row[[j]][["fun"]]=="Median"){
          cmd <- paste0(cmd,";names(out)[j]<-","\"","MEDIAN","\"")
        }
        
        
        ########################################################################
        
        if(returnCommands){
          cmd <- gsub("out[[j]] <- ",paste0("'row ",j,", col ", whichcol, "': "),cmd,fixed=TRUE)
          cmd_list[[j]] <- cmd
        }else{
          eval(parse(text=cmd))
        }
        
        colcommands<- origcolcommands
        colx <- colx.orig
        row <- row.orig
        rm(cmd,args);gc()
        
      }#ende for-Schleife
      if(returnCommands){
        out <- cmd_list
      }
      if(length(novaluelist)>0){
        out[[length(out)+1]] <- novaluelist
      }
      return(out)
    })
    
    save.out <- out
    
    
    # novaluelist enthaelt die Zeilen und Spalten fuer Zellen die (derzeit) nicht richtig berechnet werden koennen,
    # also z.B. Spalte ist GroupRate und Zeile ist Mean
    if(!all(sapply(out,function(z)length(z))==length(col))){
      novaluelist <- lapply(out,function(x)x[(length(row)+1):max(sapply(out,function(z)length(z)))])
      out <- lapply(out,function(x)x[1:length(row)])
    }  
    
    
    if(!returnCommands){
      
      # if(emptyRows){
      #   
      #   out1 <- lapply(out,function(x)lapply(x,function(y){
      #     if(estimator%in%names(y)){
      #       return(c(NA,y[[estimator]]))
      #     }else{
      #       c(NA,sapply(y,function(z)z[[estimator]]))
      #     }
      #   }))
      #   outErrorval <- lapply(out,function(x)lapply(x,function(y){
      #     if(estimator%in%names(y)){
      #       return(c(NA,y[[error]]))
      #     }else{
      #       c(NA,sapply(y,function(z)z[[error]]))
      #     }
      #   }))
      # }else{
      out1 <- lapply(out,function(x)lapply(x,function(y){
        if(estimator%in%names(y)){
          return(c(y[[estimator]]))
        }else{
          c(sapply(y,function(z)z[[estimator]]))
        }
      }))
      
      
      if(!grepl("cil",error,fixed=TRUE)){
        # 1. Fall error=cv
        outErrorval <- lapply(out,function(x)lapply(x,function(y){
          if(estimator%in%names(y)){
            return(c(y[[error]]))
          }else{
            #gibt es diesen Fall hier ueberhaupt noch? War das nicht fuer each frueher oder so?
            #c(sapply(y,function(z)z[[error]]))
            stop("Extrawurst-Fall bei MakeTable() gibt es noch! Bei Angelika melden bitte!\n")
          }
        }))
      }else{
        # 2. Fall error=cil und ciu
        error2 <- gsub("cil","ciu",error,fixed=TRUE)
        outErrorval <- lapply(out,function(x)lapply(x,function(y){
          if(estimator%in%names(y)){
            if(is.na(y[[error]]) | is.na(y[[error2]])){
              return(NA)
            }else{
              if(c(y[[error]])<=0 && c(y[[error2]])>=0){#abfragen ob 0 im KI liegt
                return(2)#falls ja, mit markLeft1 und markLeft2 markieren
              }else{
                return(0)
              }
            }
          }else{
            #gibt es diesen Fall hier ueberhaupt noch? War das nicht fuer each frueher oder so?
            stop("Extrawurst-Fall bei MakeTable() gibt es noch! Bei Angelika melden bitte!\n")
          }
        }))
      }
      
      # }
      
      
      ### Hier setzen wir die Listenelemente auf TRUE, die in der Tabelle nicht angezeigt werden sollen weil 
      ### nicht das berechnet wurde (bzw. werden kann) was in Zeile und Spalte vorgegeben wurde
      ### Also Bsp. Mean in Zeile, GroupRate in Spalte -> Raten von Mittelwerten und sowas sind derzeit nicht vorgesehen
      if(exists("novaluelist")){
        out4 <- out1
        out4 <- lapply(out4,function(x)lapply(x,function(y)y=="abrakadabrasimsalabim"))
        for(k in 1:length(novaluelist)){
          if(is.list(novaluelist[[k]][[1]])){
            for(le in 1:length(novaluelist[[k]][[1]])){
              novaluerow <- as.numeric(novaluelist[[k]][[1]][[le]][names(novaluelist[[k]][[1]][[le]])=="row"])
              out4[[k]][[novaluerow]] <- lapply(out4[[k]][[novaluerow]],function(z)!isTRUE(z))
            }
          }
        }
        out4 <- do.call("cbind",lapply(out4,function(x)do.call("c",x)))  
        
      }
      
      
      if(any(grepl("scaleF",row))){
        
        leout1 <- length(out1)
        out1[[(leout1+1)]] <- list()
        #rowScale <- as.list(rep(NA,length(row)))
        for(k in 1:length(row)){
          if(any(grepl("scaleF",names(row[[k]])))){  
            #rowScale[[k]] <- row[[k]][["scaleF"]]
            out1[[(leout1+1)]][[k]] <- rep(row[[k]][["scaleF"]],length(out1[[leout1]][[k]]))
          }else{
            out1[[(leout1+1)]][[k]] <- rep(NA,length(out1[[leout1]][[k]]))
          }
        }
        out1.2 <- do.call("cbind",lapply(out1,function(x)do.call("c",x)))
        rowScale <- out1.2[,ncol(out1.2)]
        rm(out1.2);gc()
        out1[[length(out1)]] <- NULL
        out1 <- do.call("cbind",lapply(out1,function(x)do.call("c",x)))
        
      }else{
        out1 <- do.call("cbind",lapply(out1,function(x)do.call("c",x)))
      }
      
      
      out2 <- do.call("cbind",lapply(outErrorval,function(x)do.call("c",x)))>lim1
      out3 <- do.call("cbind",lapply(outErrorval,function(x)do.call("c",x)))>lim2
      
      
      out2[is.na(out2)] <- FALSE
      out3[is.na(out3)] <- FALSE
      
      
      
      for(j in 1:ncol(out1)){
        if(!any(grepl("scaleF",row))){
          if("scaleF"%in%names(col[[j]])){
            out1[,j] <- eval(parse(text=paste0("out1[,",j,"]",col[[j]][["scaleF"]]))) 
          }
          if("digits"%in%names(col[[j]])){
            out1[,j] <- round(out1[,j],digits=col[[j]][["digits"]]) 
          }
        }else{
          if("scaleF"%in%names(col[[j]])){
            out1[is.na(rowScale),j] <- eval(parse(text=paste0("out1[is.na(rowScale),",j,"]",col[[j]][["scaleF"]]))) 
            rowind <- which(!is.na(rowScale))
            for(k in rowind){
              out1[k,j] <- eval(parse(text=paste0("out1[k,",j,"]",rowScale[k]))) 
            }
          }
          if("digits"%in%names(col[[j]])){
            out1[,j] <- round(out1[,j],digits=col[[j]][["digits"]]) ## Fuer digits machen wir das ganze Tamtam derzeit nicht
          }
          
          
        }
      }
      
      
      save.out1 <- out1
      if(lim1<lim2){
        if(any(out2)){
          if(is.null(markValue1))
            out1[out2] <- paste0(markLeft1,out1[out2],markRight1)
          else
            out1[out2] <- paste0(markLeft1,markValue1,markRight1) 
        }
        if(any(out3)){
          if(is.null(markValue2))
            out1[out3] <- paste0(markLeft2,save.out1[out3],markRight2)
          else
            out1[out3] <- paste0(markLeft2,markValue2,markRight2) 
        }
      }else{
        if(lim1>lim2)
          warning("\n Achtung: lim1<lim2 ist nicht erfuellt! Falls Absicht, diese Warnung bitte ignorieren.\n")
        
        if(any(out3)){
          if(is.null(markValue2))
            out1[out3] <- paste0(markLeft2,out1[out3],markRight2)
          else
            out1[out3] <- paste0(markLeft2,markValue2,markRight2)
        }
        if(any(out2)){
          if(is.null(markValue1))
            out1[out2] <- paste0(markLeft1,save.out1[out2],markRight1)
          else
            out1[out2] <- paste0(markLeft1,markValue1,markRight1)
        }
      }
      
      if(exists("out4")){
        out4 <- matrix(as.logical(out4),nrow=nrow(out2),ncol=ncol(out2))##?? eh richtige Reihenfolge von Vektor zu Matrix?
        
        out1[out4] <- NA
        
      }
      
      if(!is.null(block)){
        if(!is.null(block[[i]])){
          #         if(!emptyRows){
          #           blocktrenner <- rep(NA,ncol(out1))
          #           out1 <- rbind(blocktrenner,out1)
          #         }
          # if(emptyRows){
          #   rownames(out1)[1]<- paste0("BLOCK_",as.character(as.name(block[[i]])))
          # }
          
        }
        outlist[[length(outlist)+1]] <- out1
        dat <- copy(save.dat) 
      }
    }else{#Ende von !returnCommands   
      if(!is.null(block)){
        outcmd_list[[length(outcmd_list)+1]] <- out
      }
    }
  } #Ende von Block schleife
  if(!is.null(block) && !(returnCommands))
    out1 <- do.call(rbind,outlist)
  else if(!is.null(block) && returnCommands)
    out1 <- outcmd_list
  else if(returnCommands)
    out1 <- out
  #   if(!is.numeric(out1)) #Output herrichten fuer dec="," in csv-Files
  #     out1 <- gsub(".",",",out1,fixed=TRUE)
  
  
  out1
}