R/MakeAKETimeInstantsTable.R

In statistikat/mzR: mzR - To compute estimates and their errors for Austrian microcensus data

## Nur fuer Hausinterne Tabellen die ueber ImportData funktionieren; nicht IndivImportData.
# TO DO: alle lim Parameter von MakeTable hier auch als Parameter dazugeben


#' Sehr spezifische Funktion zur Erstellung von Tabellen im
#' MZ-Quartalsbericht-Format basierend auf MZ-Quartalsdaten die automatisch eingelesen werden.
#' 
#' Funktion erstellt Tabellen in einem Format das im
#' Mikrozensus-Quartalsbericht ueblich ist. Die zugehoerigen MZ-Daten werden 
#' dabei automatisch dem STAT-Filemanagement entsprechend eingelesen, d.h. diese 
#' Funktion funktioniert nur STAT-intern
#' 
#' \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} und \code{Total} 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.
#' 
#' \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 optional. 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). Dasselbe gilt weitgehend auch fuer \code{fun}, solange es Sinn
#' macht - hier kann es zu Faellen kommen wo kein Ergebnis ausgegeben werden
#' kann.
#' 
#' Info: \code{returnCommands} wie in \code{MakeTable()} ist hier (noch) nicht
#' implementiert, da diese Funktion eigentlich nur als Beispiel dienen
#' sollte... Kann aber bei Bedarf gemacht werden.
#' 
#' @param col Listenobjekt um Spalten zu definieren, siehe Details.
#' @param row Listenobjekt oder NULL um Zeilen zu definieren, siehe Details.
#' @param timeInstant numerischer Vektor mit 2 Elementen: c(jahr, quartal).
#' Hier gibt man den Zeitpunkt an auf den sich alle Ergebnisse im weitesten
#' Sinn beziehen sollen, also i.d.R. das aktuellste Quartal.
#' @param nbw numerischer Wert: Anzahl an Bootstrap-Gewichten die eingelesen
#' werden soll (z.B. um Rechenzeit beim Aufsetzen der Tabellen zu verkuerzen).
#' @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.
#' @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.
#' @param markValue2 character oder NULL: falls NULL, wird der jeweilige Wert
#' von \code{estimator} nicht ueberschrieben.
#' @param markLeft2 character: wird links zu \code{markValue2} hinzugefuegt.
#' @param markRight2 character: wird rechts zu \code{markValue2} hinzugefuegt.
#' @return Output ist eine Tabelle in Matrix-Form nach demselben System wie die
#' meisten Tabellen im MZ-Quartalsbericht - mit durch \code{col} und \code{row}
#' definierten Spalten und Zeilen fuer bestimmte Zeitpunkte und Veraenderungen.
#' @seealso
#' \code{\link{MakeTable},\link{FillExcelTemplate},\link{ImportData},\link{IndivImportData}}
#' @export
#' @examples
#' \dontrun{
#' ### Spalten
#' col <- list()
#' col[[length(col)+1]] <- list(fun="GroupSize",
#'   TFstring="xerwstat!=4", scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupSize",
#'   TFstring="xerwstat!=4 & balt>=15", scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupSize",
#'   TFstring="xerwstat!=4 & balt>=15 & balt<=64", scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupSize",
#'   TFstring="xerwstat%in%c(1,2) & balt>=15", scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupSize",
#'   TFstring="xerwstat%in%c(1,2) & balt>=15 & balt<=64", scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupRate",
#'   TFstring="xerwstat%in%c(1,2) & balt>=15 & balt<=64",
#'   TFstring2="xerwstat!=4 & balt>=15 & balt<=64")
#' 
#' col[[length(col)+1]] <- list(fun="GroupSize",
#'   TFstring="xerwstat==1 & balt>=15", scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupSize",
#'   TFstring="xerwstat==1 & balt>=15 & balt<=64", scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupRate",
#'   TFstring="xerwstat==1 & balt>=15 & balt<=64",
#'   TFstring2="xerwstat!=4 & balt>=15 & balt<=64")
#' 
#' col[[length(col)+1]] <- list(fun="GroupSize",
#'   TFstring="xerwstat==2 & balt>=15", scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupRate",
#'   TFstring="xerwstat==2 & balt>=15",
#'   TFstring2="xerwstat%in%c(1,2) & balt>=15 & balt<=74")
#' 
#' col[[length(col)+1]] <- list(fun="GroupSize",
#'   TFstring="xerwstat==3 & balt>=15", scaleF="/1000")
#' col[[length(col)+1]] <- list(fun="GroupSize",
#'   TFstring="xerwstat==3 & balt>=15 & balt<=64", scaleF="/1000")
#' 
#' ### Zeilen
#' row <- list(NULL,each="bsex")  
#' 
#' ### Erstellen 2 Tabellen fuer FillExcelTemplate();
#' ### einmal mit und einmal ohne Limits 
#' # Tabelle 1: Mit Limits
#' tab1 <- MakeTimeInstantsTable(col=col,row=row,timeInstant=c(2014,4),
#'   nbw=5, lim1=0.17,lim2=0.25)
#' # Tabelle 2: Ohne Limits
#' tab2 <- MakeTimeInstantsTable(col=col,row=row,timeInstant=c(2014,4),nbw=5)
#' }
#' 
MakeAKETimeInstantsTable <- function(col,row=NULL,timeInstant,nbw=NULL,
                                  lim1=Inf,markLeft1="(",markRight1=")",markValue1=NULL,
                                  lim2=Inf,markLeft2="(",markRight2=")",markValue2="x"){
  ende <- timeInstant  

  tInterval <- date_decimal(as.numeric(time(ts(start=start(lag(ts(end=ende,frequency=4),3)),end=ende,frequency=4))))
  jahr_seq <- lubridate::year(tInterval)
  quartal_seq <- lubridate::quarter(tInterval)
  
  vjq <- date_decimal(as.numeric(time(lag(ts(end=ende,frequency=4),4))))
  vjq_jahr <- lubridate::year(vjq)
  vjq_quartal <-  lubridate::quarter(vjq)
  
  vvjq <- date_decimal(as.numeric(time(lag(ts(end=ende,frequency=4),8))))
  vvjq_jahr <- lubridate::year(vvjq)
  vvjq_quartal <-  lubridate::quarter(vvjq)
  
  timeInstants_jahr <- c(vvjq_jahr,jahr_seq)
  timeInstants_quartal <- c(vvjq_quartal,quartal_seq)
  
  
  # brauche das jew. vierte Element dieser timeInstants_jahr und timeInstants_quartal Vektoren eigentlich nicht weil das ueber comp_diff_lag abgedeckt wird
  # verwende es aber spaeter noch fuer was andres, lass es also erst mal drinnen
  
  res <- list()
  for(i in 1:length(timeInstants_jahr)){
    jahr <- timeInstants_jahr[i]
    quartal <- timeInstants_quartal[i]
    
    if(jahr==ende[1]&&quartal==ende[2]){
      ### Aktuelles Quartal
      dat <- ImportData(year=jahr,quarter=quartal,comp_diff_lag=1,nbw=nbw)
      res[[length(res)+1]] <- MakeTable(dat,col=col,row=row, error="cv", lim1=lim1,lim2=lim2)
      names(res)[length(res)] <- paste0(quartal,". Quartal ", jahr)
      ### Vorquartal
      res[[length(res)+1]] <- MakeTable(dat,col=col,row=row, estimator="estPrev",error="cv", lim1=lim1,lim2=lim2)
      names(res)[length(res)] <- paste0(quartal_seq[length(quartal_seq)-1],". Quartal ", jahr_seq[length(jahr_seq)-1])
      if(lim1==Inf && lim2==Inf){
        res[[length(res)+1]] <- MakeTable(dat,col=col,row=row, estimator="absChange",error="cv", lim1=lim1,lim2=lim2)
      }else{
        res[[length(res)+1]] <- MakeTable(dat,col=col,row=row, estimator="absChange",error="ci",markLeft1 = "", markRight1 = "*")
      }
      names(res)[length(res)] <- paste0(quartal,". Quartal ", jahr," Diffvq")
      rm(dat);gc()
      
      ### Vorjahresquartal
      dat <- ImportData(year=jahr,quarter=quartal,comp_diff_lag=4,nbw=nbw)
      res[[length(res)+1]] <- MakeTable(dat,col=col,row=row, estimator="estPrev", error="cv", lim1=lim1,lim2=lim2)
      names(res)[length(res)] <- paste0(vjq_quartal,". Quartal ", vjq_jahr)
      if(lim1==Inf && lim2==Inf){
      res[[length(res)+1]] <- MakeTable(dat,col=col,row=row, estimator="absChange", error="cv",lim1=lim1,lim2=lim2)
      }else{
        res[[length(res)+1]] <- MakeTable(dat,col=col,row=row, estimator="absChange", error="ci",markLeft1 = "", markRight1 = "*")
      }
      names(res)[length(res)] <- paste0(quartal,". Quartal ", jahr," Diffvjq")
      rm(dat);gc()
    }else if(!identical(c(jahr,quartal),c(jahr_seq[length(jahr_seq)-1] ,quartal_seq[length(quartal_seq)-1]))){
      ### Rest
      dat <- ImportData(year=jahr,quarter=quartal,nbw=nbw)
      res[[length(res)+1]] <- MakeTable(dat,col=col,row=row, error="cv", lim1=lim1,lim2=lim2)
      names(res)[length(res)] <- paste0(quartal,". Quartal ", jahr)
      rm(dat);gc()
    }
  }
  ## res umsortieren:
  res <- res[c(paste0(vvjq_quartal,". Quartal ", vvjq_jahr),paste0(vjq_quartal,". Quartal ", vjq_jahr),
               paste0(quartal_seq,". Quartal ", jahr_seq),
               paste0(quartal,". Quartal ", jahr," Diffvjq"),paste0(quartal,". Quartal ", jahr," Diffvq"))]
  
  nbloecke <- nrow(na.omit(res[[1]]))
  bloecke <- list()
  
  # if(emptyRows){
  #   ## neue Bloecke formen:
  #   for(i in 1:nbloecke){
  #     bla <- do.call(rbind,lapply(res,function(x)na.omit(x)[i,]))
  #     
  #     zeile <- as.data.frame(matrix(rep(NA,(ncol(bla))),nrow=1))
  #     #row.names(zeile) <- rownames(na.omit(res[[1]]))[i]
  #     row.names(zeile) <- ""
  #     bla <- rbind(bla[1:(which(rownames(bla)==paste0(quartal,". Quartal ", jahr," Diffvjq")))-1,], zeile, 
  #                  bla[(which(rownames(bla)==paste0(quartal,". Quartal ", jahr," Diffvjq"))):nrow(bla),])
  #     bloecke[[length(bloecke)+1]] <- rbind(zeile,zeile,bla)
  #     #bloecke[[length(bloecke)+1]] <- do.call(rbind,lapply(res,function(x)na.omit(x)[i,]))
  #     names(bloecke)[length(bloecke)] <-rownames(na.omit(res[[1]]))[i]
  #   }
  # }else{
    ## neue Bloecke formen:
    for(i in 1:nbloecke){
      bloecke[[length(bloecke)+1]] <- do.call(rbind,lapply(res,function(x)na.omit(x)[i,]))
    }
  # } 
  
  (ergebnis <- do.call(rbind,bloecke))  
  
  return(ergebnis)
}