R/Redressement.R

Defines functions func_aux redressement

Documented in func_aux redressement

# copyright (C) 2014-2016 M.Huang
# This function executes easy calibration with just data and data's variables

#########
#' Calibration on margins
#' @description
#' Performs calibration on margins
#' @param df The dataframe containing the population
#' @param var_cible target to calibrate
#' @param liste_var1 a list containing calibration variables
#' @param var2 whole population
#' @param var3 survey samplings
#' @param ecart delta
#'
#' @examples
#'
#'res <- redressement(df,"resil",c("DESENG"),"PARC","DEPR_ID")
#'poids <- res$a
#'cible_redresse <- res$b
#'
#' @return list containing weights and target calibrated
#'
#' @export


redressement <- function(df,var_cible,liste_var1,var2,var3,ecart = NULL){
  #si une seule variable de redressement
  if(length(liste_var1) == 1){
    #tableau croise entre var3 et var1 sur tout le parc
    ct_var2 <- as.data.frame.matrix(xtabs(df[,var2]~df[,var3]+df[,liste_var1[1]], data=df))
    #tableau croise entre var3 et var1 sur les resiliations
    ct_cible <- as.data.frame.matrix(xtabs(df[,var_cible]~df[,var3]+df[,liste_var1[1]], data=df))
    #nb modalite de var1
    mod <- colnames(ct_var2)
    cible_redresse <- func_aux(ct_var2,ct_cible,mod,var_cible,var2,var3,ecart = NULL)
  }
  #si deux variables de redressement
  else if(length(liste_var1) == 2){
    #tableau croise avec multi index en colonnes (les vars de redressement)
    ct_var2 <- acast(transform(df, var23 = paste(df[,liste_var1[1]], df[,liste_var1[2]], sep="-")),
                     df[,var3]~var23, value.var = var2, sum)
    ct_cible <- acast(transform(df, var23 = paste(df[,liste_var1[1]], df[,liste_var1[2]], sep="-")),
                      df[,var3]~var23, value.var = var_cible, sum)
    ct_var2 <- as.data.frame(ct_var2)
    ct_cible <- as.data.frame(ct_cible)
    mod <- colnames(ct_var2)
    cible_redresse <- func_aux(ct_var2,ct_cible,mod,var_cible,var2,var3,ecart = NULL)
  }
  #si trois varialbes de redressment
  else if(length(liste_var1) == 3){

    ct_var2 <<- acast(transform(df, var23 = paste(df[,liste_var1[1]], df[,liste_var1[2]],df[,liste_var1[3]], sep="-")),
                     df[,var3]~var23, value.var = var2, sum)
    ct_cible <- acast(transform(df, var23 = paste(df[,liste_var1[1]], df[,liste_var1[2]],df[,liste_var1[3]], sep="-")),
                      df[,var3]~var23, value.var = var_cible, sum)
    ct_var2 <- as.data.frame(ct_var2)
    ct_cible <- as.data.frame(ct_cible)
    mod <- colnames(ct_var2)
    cible_redresse <- func_aux(ct_var2,ct_cible,mod,var_cible,var2,var3,ecart = NULL)

  }
  #possibilite d'ajouter plus de variables de redressement.
  else{
    stop('le nb de variables de redressement max vaut 3')
  }
  return(cible_redresse)
}

#########
#'auxiliary function
#' @description
#' Performs calibration on margins
#' @param ct_var2 cross table
#' @param ct_cible cross table
#' @param mod modalities of calibration variables
#' @param var_cible target to calibrate
#' @param liste_var1 modalities of calibration variables
#' @param var2 whole population
#' @param var3 survey samplings
#' @param ecart delta
#'
#'
#' @return list containing weights and target calibrated


func_aux <- function(ct_var2,ct_cible,mod,var_cible,var2,var3,ecart){
  #calcul de la marge
  #En ligne
  ct_var2$TOTAL <- rowSums(ct_var2)
  ct_cible$TOTAL <- rowSums(ct_cible)
  #En colonne
  #print(colnames(ct_var2))
  tot_var2 <- colSums(ct_var2[,c(mod,"TOTAL")])
  tot_cible <- colSums(ct_cible[,c(mod,"TOTAL")])
  #creation d'une colonne qui prend les valeurs de l'index (var3)
  ct_var2[,var3] <- rownames(ct_var2)
  ct_cible[,var3] <- rownames(ct_cible)
  #ratio entre parc pour chaque sous pop sur parc total pour chaque modalite des vars de redressement
  tmp <- ct_var2[,as.character(mod[1])] / ct_var2$TOTAL
  for(i in 2:length(mod)){
    tmp <- cbind(tmp,ct_var2[,as.character(mod[i])] / ct_var2$TOTAL)
  }
  colnames(tmp) <- mod
  #ratio entre la population pour chaque modalite de var1 sur parc total (pop de reference)
  tmp2 <- tot_var2[1] / tot_var2[length(tot_var2)]
  for(i in 2:length(mod)){
    tmp2 <- cbind(tmp2,tot_var2[i] / tot_var2[length(tot_var2)])
  }
  tmp2 <- as.data.frame(tmp2)
  colnames(tmp2) <- mod
  #ratio entre la population ayant churne (cible) pour chaque modalite de var1 sur parc total
  taux_cible <- as.data.frame(ct_cible[,as.character(mod[1])] /ct_var2[,as.character(mod[1])])
  for(i in 2:length(mod)){
    taux_cible <- cbind(taux_cible,
                        as.data.frame(ct_cible[,as.character(mod[i])] /ct_var2[,as.character(mod[i])]))
  }
  colnames(taux_cible) <- mod


  #calcul des coefficients de ponderation pour chaque modalite de la base de redressement
  poids <- as.data.frame(as.numeric(tmp2[as.character(mod[1])]) / as.vector(tmp[,as.character(mod[1])]))

  for(i in 2:length(mod)){
    poids <- cbind(poids,
                   as.data.frame(as.numeric(tmp2[as.character(mod[i])]) / as.vector(tmp[,as.character(mod[i])])))
  }
  colnames(poids) <- mod
  #remplace les poids manquants par 0
  poids[poids == Inf] <- 0
  #ajout des labels des sous pop
  poids[,var3] <- ct_var2[,var3]

  #Calcul du redressement de la cible a partir des poids
  if(is.null(ecart)){
    cible_redresse <- ct_cible[,as.character(mod[1])] * poids[,as.character(mod[1])]
    for(i in 2:length(mod)){
      cible_redresse <- cible_redresse +(ct_cible[,as.character(mod[i])] * poids[,as.character(mod[i])])
    }
    cible_redresse <- as.data.frame(cible_redresse)
    cible_redresse <- cible_redresse / ct_var2$TOTAL
  }else{
    #TODO
  }
  return(list(a = poids,b = cible_redresse))

}
huangmatthieu/MyRCalmar documentation built on May 16, 2017, 11:28 p.m.