EEC
/
cosmosR


			
				
					
						
						
							
							#' Comparatif par groupe
#' 
#' Produit un tableau comparatif par groupe
#' 
#' Permet de produire un tableau comparatif des variables contenues dans la table passee en parametre selon les modalites d'une d'entre elles.
#' Si les labels et formats sont definis et charges ils seront utilises pour peupler le tableau.
#' Le fichier de sortie est place dans ../HTML Output
#' @encoding UTF-8
#' @param table Table a utiliser
#' @param groupe Nom de la variable qualitative a utiliser pour la comparaison
#' @param param Vecteur de noms de variables considerees comme parametriques
#' @param html Nom du fichier html, par defaut "desc_groupe_nomdelavariable.html"
#' @param titre Titre du tableau, par defaut "Comparaison selon nom_de_la_variable"
#' @param variables Vecteur de noms de variables a comparer, par defaut toutes les variables contenues dans la table moins celle servant de comparateur
#' @param variables_neg Vecteur de noms de variables a exclure de la comparaison
#' @param stats Vecteur de valeurs a calculer, parmi N, \%, \%/moy, moy, \%/med, med, et, ic95, Q1, med, Q3, min et max. Par defaut c("N","\%/moy","et")
#' @param note Note de bas de page, par defaut vide
#' @param nbdec Nombre de decimales apres la virgule, par defaut 1
#' @param pourcent Pourcentages pour les variables qualitatives, en colonnes ("col") ou en lignes ("row"), par defaut sur le total
#' @param paired Use a paired test for quantitative values. Must have equal number of observations in the two groups. Only works for two groups.
#' @examples
#' \dontrun{
#' Ma_table <- charger("donnees.xls")
#' 
#' desc_groupe(Ma_table, "sexe")
#' 
#' para <- diagnostic(Ma_table)
#' desc_groupe(Ma_table, "sexe", param = para, titre="Comparatif selon le sexe", pourcent="row")
#' }
#' @export
desc_groupe <- function(table, groupe, param = character(0), html=NULL, titre=NULL, variables=NULL, variables_neg=NULL,stats=c("N","%/moy","et"), note=NULL, nbdec=1, pourcent="total", paired=F)
{
  if (nbdec<2)
    nbdecp<-2
  else
    nbdecp<-nbdec
  
  if (missing(table))
  {
    warning("Pas de table donnee !")
    return
  }
  
  if (missing(groupe) | (!groupe %in% names(table)))
  {
    warning("Pas de comparateur !")
    return
  }
  
  modulo <- table[[groupe]]
  
  if (nlevels(modulo)<2)
  {
    warning("La variable ", groupe, " n'a qu'un niveau !")
    return
  }
  
  etiq <- label(modulo)
  if (etiq == "modulo") etiq <- groupe
  
  # Creation du titre
  if (is.null(titre))
    titre<-paste("Comparaison selon", etiq)
  
  # Creation de la table temporaire contenant les variables demandees
  if (!is.null(variables)) 
  {
    badvar <- variables[!variables %in% names(table)]
    if (length(badvar) != 0)
      warning("Les variables suivantes n'existent pas dans la table : ",paste(badvar,collapse=", "))
    table <- table[variables[variables %in% names(table)]]
  }
  if (!is.null(variables_neg))
  {
    badvar <- variables_neg[!variables_neg %in% names(table)]
    if (length(badvar) != 0)
      warning("Les variables_neg suivantes n'existent pas dans la table : ",paste(badvar,collapse=", "))
    table[variables_neg]<-list(NULL)
  }
  
  table[groupe]<-NULL
  
  # Creation du nom de fichier html
  if (is.null(html))
    html <- paste0("desc_groupe_",groupe)
  
  # Header de la table
  HTMLInit(file=paste0(html,".html"), title=titre, CSSfile="desc.css")
  HTML("<div class='desc'>")
  inc()
  HTML("<table class='desc'>")
  inc()
  HTML("<caption>", titre, "</caption>")
  HTML("<thead>")
  inc()
  
  HTML("<tr><th></th>", paste0("<th colspan='",length(stats),"'>",levels(modulo),"</th>", collapse=""), "<th>p</th></tr>")
  
  HTML("<tr><td></td>", sep="")
  for (i in levels(modulo))
    HTML("<td colspan='",length(stats),"'>N=", length(na.omit(modulo[modulo==i])), "</td>", sep="")
  
  HTML("<td></td></tr>")

  HTML("<tr><td></td>", paste0(rep(paste("<td>",stats,"</td>",sep="", collapse=""),nlevels(modulo)),collapse=""), "<td></td></tr>")

  dec()
  HTML("</thead>")
  
  # Footer de la table
  if (!is.null(note))
  {
    HTML("<tfoot>")
    inc()
    HTML("<tr><td colspan='", nlevels(modulo)*length(stats)+2, "'>", note,"</td></tr>")
    dec()
    HTML("</tfoot>")
  }
  
  # Corps de la table
  HTML("<tbody>")
  inc()
  for (var in names(table))
  {
    # Creation du label de la variable
    etiq <- label(table[[var]])
    if (etiq == "table[[var]]") etiq <- var
    
    # Variable quantitative
    if (is.numeric(table[[var]]))
    {
      if (var %in% param)
      {
        if (nlevels(modulo) == 2)
        {
          p <- tryCatch(t.test(table[[var]] ~ modulo, paired=paired,na.action=na.pass)$p.value, error=function(e){erreur(e,var,"dans le calcul du test t")})
          test <- "t"
        }
        else if (nlevels(modulo) > 2)
        {
          p <- tryCatch(summary(aov(table[[var]] ~ modulo))[[1]][["Pr(>F)"]][1], error=function(e){erreur(e,var,"dans le calcul de l'ANOVA")})
          test <- "ANOVA"
        }
      }
      else
      {
        if (nlevels(modulo) == 2)
        {
          p <- tryCatch(wilcox.test(table[[var]] ~ modulo, paired=paired, na.action=na.pass)$p.value, error=function(e){erreur(e,var,"dans le calcul du test de Mann-Whitney")})
          test <- "M-W"
        }
        else if (nlevels(modulo) > 2)
        {
          p <- tryCatch(kruskal.test(table[[var]] ~ modulo)$p.value, error=function(e){erreur(e,var,"dans le calcul du test de Kruskal-Wallis")})
          test <- "K-W"
        }
      }
      
      HTML("<tr><td class='var'>", etiq, "</td>", sep="")
      
      for (level in levels(modulo))
      {
        for (stat in stats)
        {
          HTML("<td>",sep="")
          
          HTML(tryCatch(
          {
            format(switch(stat,
                          N = length(na.omit(table[[var]][modulo==level])),
                          "%/moy" = ,
                          moy = mean(table[[var]][modulo==level],na.rm=T),
                          "%/med" = ,
                          med = median(table[[var]][modulo==level],na.rm=T),
                          Q1 = quantile(table[[var]][modulo==level], probs=.25, na.rm=T,names=F,type=3),
                          Q3 = quantile(table[[var]][modulo==level], probs=.75, na.rm=T,names=F,type=3),
                          min = min(table[[var]][modulo==level],na.rm=T),
                          max = max(table[[var]][modulo==level],na.rm=T),
                          et = sd(table[[var]][modulo==level],na.rm=T),
                          ic95 = paste0("&plusmn;",format(mean(table[[var]][modulo==level],na.rm=T) - t.test(table[[var]][modulo==level])$conf.int[1], digits=nbdec,nsmall=nbdec)),
                          ... = "ERR"
            ),digits=nbdec,nsmall=nbdec)
          },error = function(e){erreur(e,var,"dans le calcul de ",stat)}), sep="")
          
          HTML("</td>", sep="")
        }
      }
      
      HTML("<td>", format(p,digits=nbdecp,nsmall=nbdecp), sep="")
      if (!is.na(p))
        if (p<.05)
          HTML("*", sep="")
      HTML(" (",test,")</td>", sep="")
      
      HTML("</tr>")
    }
    # Variable qualitative
    else if (is.factor(table[[var]]))
    {
      test <- "X"
      p <- tryCatch(
        {
          chisq.test(table[[var]],modulo)$p.value
        },
        warning=function(w)
        {
          test <<- "f"
          tryCatch(
          {
            fisher.test(table[[var]],modulo,workspace=1e+08)$p.value
          },
          error=function(e)
          {
            #test <<- "X(f failed)"
            #chisq.test(table[[var]],modulo)$p.value
            fisher.test(table[[var]],modulo,simulate.p.value = T,B = 1e+06)$p.value
          })
        },
        error=function(e)
        {
          "NA"
        })
      
      HTML("<tr><td class='var' colspan='", nlevels(modulo)*length(stats)+1, "'>", etiq, "</td>", sep="")
      HTML("<td>", format(p,digits=nbdecp,nsmall=nbdecp), sep="")
      if (!is.na(p))
        if (p<.05)
          HTML("*", sep="")
      HTML(" (",test,")</td>", sep="")
      HTML("</tr>")
      
      # Levels de la variable qualitative
      for (level in levels(table[[var]]))
      {
        HTML("<tr><td class='level'>", level, "</td>",sep="")
        for (level_m in levels(modulo))
        {
          for (stat in stats)
          {
            HTML("<td>",sep="")
            
            if (stat == "N")
              HTML(table(table[[var]],modulo)[level,level_m],sep="")
            else if ((stat == "%") | (stat == "%/moy") | (stat == "%/med"))
              switch(pourcent,
                     row = HTML(format(100*table(table[[var]],modulo)[level,level_m]/rowSums(table(table[[var]],modulo))[level], digits=nbdec, nsmall=nbdec), sep=""),
                     col = HTML(format(100*table(table[[var]],modulo)[level,level_m]/colSums(table(table[[var]],modulo))[level_m], digits=nbdec, nsmall=nbdec), sep=""),
                     total = HTML(format(100*table(table[[var]],modulo)[level,level_m]/sum(table(table[[var]],modulo)), digits=nbdec, nsmall=nbdec), sep=""))
            
            HTML("</td>",sep="")
          }
        }
        
        HTML("<td></td></tr>")
     }
    }
    else next
  }
  dec()
  HTML("</tbody>")
  dec()
  HTML("</table>")
  HTML("</div>")
  HTMLEnd()
}