Commentaires dans charger.R

Ajout de paramètres dans desc()
Commentaires pour desc.R
Description des variables quanti
Ouverture automatique du fichier html généré dans le navigateur, et suppression de l'accès en écriture au fichier

R/charger.R

@@ -17,53 +17,69 @@
 #' charger(NULL)
 charger <- function(fichier,nom=NULL,feuille=1)
 {
+  # Detache la precedente data.frame et creation du nom de la table si non fourni
   try(detach(.attachd,character.only=T),silent=T)
   if (is.null(nom))
     nom=strsplit(fichier,"\\.")[[1]][1]
   
+  # Verification de la presence du fichier
   fichier<-paste("../../data/",fichier,sep="")
   if (!file.exists(fichier))
   {
     warning("Le fichier source n'existe pas !")
     return -1
   }
+  
+  # Lecture du fichier selon l'extension
   if (grepl("\\.csv$",fichier) || grepl("\\.txt$",fichier))
     x<-read.csv2(fichier,encoding="ISO-8859-1")
   else if (grepl("\\.xlsx?$",fichier))
     x<-read.xlsx(fichier,feuille,encoding="ISO-8859-1")
   
+  # Lecture des formats a partir du fichier SAS
   if (file.exists("formats.sas"))
   {
     formats=list(0)
+    
     con=file("formats.sas","r",encoding="ISO-8859-1")
-    formatsfile=readLines(con)
+      formatsfile=readLines(con)
     close(con)
+    
+    # Nettoyage du fichier : espaces de debut et fin, et autour des '=', conservation uniquement des lignes significatives (value xxx et 'code'='level')
     formatsfile=sub("^[[:space:]]*","",formatsfile)
     formatsfile=sub("[[:space:]]*$","",formatsfile)
     formatsfile=formatsfile[grepl("^value *\\w",formatsfile) | grepl("\\d+ *= *\\'.*?\\'",formatsfile)]
     formatsfile=sub("[[:space:]]*=[[:space:]]","=",formatsfile)
     formatsfile=sub("^(\\d+)","\\'\\1\\'",formatsfile)
+    
+    # Creation de la liste de formats
     for (format in formatsfile)
     {
       if (grepl("^value *\\w",format))
         formats[[strsplit(format," ")[[1]][2]]]<-character(0)
       else
-        eval(parse(text=paste("formats[[length(formats)]]<-c(formats[[length(formats)]],",format,")",sep="")))
+        eval(parse(text=paste0("formats[[length(formats)]]<-c(formats[[length(formats)]],",format,")")))
     }
     #formats<-lapply(formats,"attr<-",which="ordered",value=F)
     #attr(formats[[strsplit(formatsfile[grepl("^value *\\w* *order$",formatsfile)]," ")[[1]][2]]],"ordered")<-T
     formats[[1]]<-NULL
+    
+    # Lecture des attributions de format depuis le fichier SAS
     if (file.exists("attribformats.sas"))
     {
       con=file("attribformats.sas","r",encoding="ISO-8859-1")
-      attribfile=readLines(con)
+        attribfile=readLines(con)
       close(con)
+      
+      # Nettoyage du fichier : espaces de debut et fin, espaces multiples, autour des '=', '.' final, conservation uniquement des lignes significatives (finissant en format=xxx)
       attribfile=sub("^[[:space:]]*","",attribfile)
       attribfile=sub("[[:space:]]*$","",attribfile)
       attribfile=sub("\\.?$","",attribfile)
       attribfile=attribfile[grepl("(\\w[[:space:]]+)+format *= *\\w",attribfile)]
       attribfile=gsub("[[:space:]]+"," ",attribfile)
       attribfile=sub("[[:space:]]*=[[:space:]]","=",attribfile)
+      
+      # Attribution des formats aux variables concernees
       for (attrib in attribfile)
       {
         attrib=strsplit(attrib," ")[[1]]
@@ -71,14 +87,13 @@ charger <- function(fichier,nom=NULL,feuille=1)
         for (var in attrib[-length(attrib)])
         {
           if (!is.null(x[[var]]))
-          {
               x[[var]]<-factor(x[[var]],levels=names(formats[[format]]),labels=formats[[format]])#,ordered=attr(formats[[format]],"ordered"))
-          }
         }
       }
     }
   }
   
+  # Lecture des labels a partir du fichier SAS
   if (file.exists("labels.sas"))
   {
     con=file("labels.sas","r",encoding="ISO-8859-1")
@@ -90,6 +105,7 @@ charger <- function(fichier,nom=NULL,feuille=1)
     eval(parse(text=label_exe))
   }
   
+  # Enregistrement de la table dans l'environnement, attach et assignation de la variable .attachd
   assign(".attachd",nom,pos=1)
   assign(nom,x,pos=1)
   attach(eval(parse(text=.attachd)),name=.attachd)

R/desc.R

@@ -11,7 +11,7 @@
 #' @param table Table a utiliser, par defaut la derniere chargee
 #' @param variables Vecteur de noms de variables a decrire, par defaut toutes les variables contenues dans la table
 #' @param variables_neg Vecteur de noms de variables a exclure de la description
-#' @param stats Vecteur de valeurs a calculer, parmi N, \%, \%/moy, moy, et, ic95, q1, med, q3. Par defaut c("N","\%/moy","ic95")
+#' @param stats Vecteur de valeurs a calculer, parmi N, \%, \%/moy, moy, \%/med, med, et, ic95, q1, med, q3. Par defaut c("N","\%/moy","ic95")
 #' @param miss Booleen : afficher ou non les valeurs manquantes, par defaut TRUE
 #' @param anglais Booleen : obtenir un tableau en anglais(intitules, separation des decimales), par defaut FALSE
 #' @param note Note de bas de page, par defaut vide
@@ -24,15 +24,18 @@ desc <- function(html="desc", titre=NULL, table=NULL, variables=NULL, variables_
   else
     decmark=","
   
+  # Creation du titre
   if (is.null(titre) & is.null(table))
     titre<-paste("Descriptif global de",.attachd)
   else if (is.null(titre))
     titre<-paste("Descriptif global de",deparse(substitute(table))) 
-
+  
+  # Creation de la table temporaire contenant les variables demandees
   if (is.null(table)) table<-eval(parse(text=.attachd))
   if (!is.null(variables)) table=table[variables]
   if (!is.null(variables_neg)) table[variables_neg]<-list(NULL)
   
+  # Header de la table
   HTMLInit(file=paste0("../HTML\ Output/",html,".html"), title=titre)
   HTML("<table>")
   inc()
@@ -42,76 +45,103 @@ desc <- function(html="desc", titre=NULL, table=NULL, variables=NULL, variables_
       HTML("<tr><th></th>", paste("<th>",stats,"</th>",sep="", collapse=""), "</tr>")
     dec()
     HTML("</thead>")
-    if (!is.null(note))
-    {
+  
+  # Footer de la table
+  if (!is.null(note))
+  {
       HTML("<tfoot>")
       inc()
         HTML("<tr><td colspan='", length(stats)+1, "'>", note,"</td></tr>")
       dec()
       HTML("</tfoot>")
-    }
+  }
+  
+  # Corps de la table
     HTML("<tbody>")
     inc()
-      for (var in names(table))
+  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]]))
+    {
+      HTML("<tr><td class='var'>", etiq, "</td>", sep="")
+      
+      res <- NA
+      for (stat in stats)
       {
-        etiq <- label(table[[var]])
-        if (etiq == "table[[var]]") etiq <- var
+        HTML("<td>",sep="")
         
-        if (is.numeric(table[[var]]))
+        HTML(format(switch(stat,
+          N = length(na.omit(table[[var]])),
+          "%/moy" = ,
+          moy = mean(table[[var]],na.rm=T),
+          "%/med" = ,
+          med = median(table[[var]],na.rm=T),
+          Q1 = quantile(table[[var]], probs=.25, na.rm=T),
+          Q3 = quantile(table[[var]], probs=.75, na.rm=T),
+          min = min(table[[var]],na.rm=T),
+          max = max(table[[var]],na.rm=T),
+          et = sd(table[[var]],na.rm=T),
+          ic95 = paste0("±",format(mean(table[[var]],na.rm=T) - t.test(table[[var]])$conf.int[1], digits=nbdec,nsmall=nbdec,decimal.mark=decmark))
+          ),digits=nbdec,nsmall=nbdec,decimal.mark=decmark), sep="")
+        
+        HTML("</td>", sep="")
+      }
+      
+      HTML("</tr>")
+    }
+    # Variable qualitative
+    else if (is.factor(table[[var]]))
+    {
+      HTML("<tr><td class='var' colspan='", length(stats)+1, "'>", etiq, "</td></tr>")
+      
+      # Donnees manquantes
+      if ((miss) & (!is.na(summary(table[[var]])["NA's"])))
+      {
+        if (anglais)
+      HTML("<tr><td class='level'>Missing</td>",sep="")
+        else
+      HTML("<tr><td class='level'>Manquant</td>",sep="")
+      
+        for (stat in stats)
         {
-          res <- NA
-          for (stat in stats)
-          {
-            
-          }
+        HTML("<td>",sep="")
+      
+          if (stat == "N")
+        HTML(summary(table[[var]])["NA's"],sep="")
+#         else if ((stat == "%") | (stat == "%/moy"))
+#       HTML(format(mean(is.na(table[[var]]))*100,digits=nbdec,nsmall=nbdec,decimal.mark=decmark),sep="")
+      
+        HTML("</td>",sep="")
         }
-        else if (is.factor(table[[var]]))
+      HTML("</tr>")
+      }
+
+      # Levels de la variable qualitative
+      for (level in levels(table[[var]]))
+      {
+      HTML("<tr><td class='level'>", level, "</td>",sep="")
+        for (stat in stats)
         {
-          HTML("<tr><td class='var' colspan='", length(stats)+1, "'>", etiq, "</td></tr>")
-          
-          if ((miss) & (!is.na(summary(table[[var]])["NA's"])))
-          {
-            if (anglais)
-              HTML("<tr><td class='level'>Missing</td>",sep="")
-            else
-              HTML("<tr><td class='level'>Manquant</td>",sep="")
-            for (stat in stats)
-            {
-              HTML("<td>",sep="")
-              if (stat == "N")
-              {
-                HTML(summary(table[[var]])["NA's"],sep="")
-              }
-#               else if ((stat == "%") | (stat == "%/moy"))
-#               {
-#                 HTML(format(mean(is.na(table[[var]]))*100,digits=nbdec,nsmall=nbdec,decimal.mark=decmark),sep="")
-#               }
-              HTML("</td>",sep="")
-            }
-            HTML("</tr>")
-          }
-          for (level in levels(table[[var]]))
-          {
-            HTML("<tr><td class='level'>", level, "</td>",sep="")
-            for (stat in stats)
-            {
-              HTML("<td>",sep="")
-              if (stat == "N")
-              {
-                HTML(summary(table[[var]])[level],sep="")
-              }
-              else if ((stat == "%") | (stat == "%/moy"))
-              {
-                HTML(format(100*summary(table[[var]])[level]/length(na.omit(table[[var]])),digits=nbdec,nsmall=nbdec,decimal.mark=decmark),sep="")
-#                 HTML(format(100*summary(table[[var]])[level]/length(table[[var]]),digits=nbdec,nsmall=nbdec,decimal.mark=decmark),sep="")
-              }
-              HTML("</td>",sep="")
-            }
-            HTML("</tr>")
-          }
+        HTML("<td>",sep="")
+      
+          if (stat == "N")
+        HTML(summary(table[[var]])[level],sep="")
+          else if ((stat == "%") | (stat == "%/moy") | (stat == "%/med"))
+        HTML(format(100*summary(table[[var]])[level]/length(na.omit(table[[var]])),digits=nbdec,nsmall=nbdec,decimal.mark=decmark),sep="")
+#       HTML(format(100*summary(table[[var]])[level]/length(table[[var]]),digits=nbdec,nsmall=nbdec,decimal.mark=decmark),sep="")
+
+        HTML("</td>",sep="")
         }
-        else next
+      HTML("</tr>")
       }
+    }
+    else next
+  }
     dec()
     HTML("</tbody>")
   dec()

R/html.R

@@ -32,7 +32,7 @@ HTMLInit <- function(file=tempfile(pattern="report", fileext=".html"), title="")
 #' 
 #' Ecrit le footer du fichier hTML
 #' 
-#' Ecrit le footer du fichier initialise par HTMLInit, et en supprime l'acces.
+#' Ecrit le footer du fichier initialise par HTMLInit, ouvre le fichier dans le navigateur et supprime l'acces.
 #' @encoding UTF-8
 #' @export
 HTMLEnd <- function()
@@ -43,6 +43,9 @@ HTMLEnd <- function()
     HTML("</BODY>")
   dec()
   HTML("</HTML>")
+  
+  browseURL(.HTML.file)
+  rm(.HTML.file,pos=1)
 }
 
 #' Ecrit dans le fichier HTML

man/HTMLEnd.Rd

@@ -9,7 +9,7 @@
   Ecrit le footer du fichier hTML
 }
 \details{
-  Ecrit le footer du fichier initialise par HTMLInit, et en
-  supprime l'acces.
+  Ecrit le footer du fichier initialise par HTMLInit, ouvre
+  le fichier dans le navigateur et supprime l'acces.
 }
 

man/desc.Rd

@@ -26,8 +26,8 @@
   exclure de la description}
 
   \item{stats}{Vecteur de valeurs a calculer, parmi N, \%,
-  \%/moy, moy, et, ic95, q1, med, q3. Par defaut
-  c("N","\%/moy","ic95")}
+  \%/moy, moy, \%/med, med, et, ic95, q1, med, q3. Par
+  defaut c("N","\%/moy","ic95")}
 
   \item{miss}{Booleen : afficher ou non les valeurs
   manquantes, par defaut TRUE}