Les 267 fonctions de statgh.r (version 6.47) Chargement des fonctions :           source("http://forge.info.univ-angers.fr/~gh/wstat/statgh.r",encoding="latin1") Choisissez la fonction : acp acpFacteur acpLoadings addClassMeans aide ajouteTotaux ajusteNomsColonnes allCalcQT allQL allQLm allQLnonum allQLrecap allQLtriap allQLtricr allQT allQT2 allQTdf allqtdbf anaLin anaTcr analexies analyseCoefficientsModeleLogistique analyseMedianes analyseRegression anared approxPoissNorm approximationBinomiale approximationPoissonnienne approximations as.sigcode asc attends auroc aurocQlPred aurocs aurocs_delong bbpQT beanplotQT bendist bestCor bestCorDf bestGroupRep bestValAssoc bioc bloc boxplotQT cadreCah2co cah2co catln catn cats catss cb cd cdr cdrn chaineEnListe chaineEnVectNum charToNum checklm chi2 chi2Adeq chi2Indep chi2IndepTable chi2IndepTableFacteur chr clusterCor clusterCorTrans coefficientsRLB col.names col2fact colMaxs colMedians colMins compMoyData compMoyNoData compPourc compare2QT compare2QTappariees compareScoresBinaires compareScoresFL compareScoresMetavir copies corCircle couleursFL couleursMetavir couleursNmds cpt cr cv datagh ddata debutHtml decritClass decritModeleLogistiqueBinaire decritQL decritQLf decritQT decritQTparFacteur decritQTparFacteurTexte decritRLB devoff df2csv df2dac dfSansCor dfSansNA dimdf dims discordance dql dqt dtQT duree ecrit.csv ecrit.dac ecrit.dar ecrit.df ecrit.xls ect enColonnes enFacteur exploreCorrelations exprimeDuree extrait fcomp finHtml finsink fql fqt ghtrim go gr hbbpQT hhead histEffectifs histProba histQL histoQT hprint htmlsrc ic ice iceQT icm icmQT icp identif identifgc ifiab installe lesColonnes lesVariables lib ligneCadreCtrACP lignePointillesACP linCor linmodelstats lit lit.dac lit.dar lit.dar.lh lit.dar.wd lit.dat lit.dbf lit.texte lit.xls litcol lls lstMod matCor matId matPen maxMatCor mcomed mdc milieu milieux minMatCor modalitesFL modalitesMetavir modelesCLMMetavir modelesFDAMetavir modelesLDAMetavir modelesMDAMetavir modelesQDAMetavir modelesRLB modelesRLIMetavir mot mots moy nbmots noask noconst nodup nomDeFichier nombase nonoui numeroteId optionsPrint ouinon pairsi panel.cor panel.cor2 panel.corpvalue panel.pointsreg parPrint pchShow pctBcLda plotQL plotQT plotQTdet print10 pwd rchModeleLogistique rch_VE recadrage redata reduitVarsCor reformate regh regressionLogistiqueBinaire regressionLogistiqueOrdinale regressionLogistiqueOrdinale2 rlo_ord rlobin rownames rsd ruler run scr sdmax sdr sensSpec showColors simule sinksource sinksrc skku somCols sorsrc src strlen surncarg tailleEchMoy tailleEchProp tdn tmp traceCor traceLin traceQL traceRLB traceTcr triAPlats triAplat triAplatAvecOrdre triAplatNonum triCroise triCroiseBC triCroiseSansMarges triaplat ucfirst vecteurEnChaine verifSol versiongh violinplotQT vvar xls2dar z ## (gH) -_- statgh.r ; TimeStamp (unix) : 22 Juillet 2020 vers 13:29 # version_gH <- 6.47 ################################################################# # # +----------------------------------------------- (gH) --+ # | | # | statgh.r : quelques fonctions utiles | # | en Rstat pour les statistiques | # | descriptives, les lois et les tests. | # | | # +-------------------------------------------------------+ # # chargement des fonctions : # # source("http://forge.info.univ-angers.fr/~gh/wstat/statgh.r",encoding="latin1") # ################################################################# # # dernières modifications 2019 # ----------------------- # # finsink(), devoff(), run() # ruler, traceRLB,exploreCorrelations, extrait # exprimeDuree, showColors, aurocs_delong, couleursNmds # # . octobre 2013 : ddata(), lls(), hhead(), bioc() # . septembre 2013 : triCroiseBC(), analyseMedianes() # . mai 2013 : analyseRegression() # . octobre 2012 : bloc(df) aurocs(dataFrame,nomData,nomCible,nomVars) # . septembre 2012 : ajouteTotaux( table) # # . juin 2012 : dims, reprise de lesColonnes # . janvier 2012 : concatv, duree, enColonnes # . décembre 2011 : parPrint et optionsPrint # . octobre 2011 : colMedians, colMaxs, colMins, approximationBinomiale, approximationPoissonnienne # . aout 2011 : ajout de cd, pwd, strlen, chr, asc et allQLm, modification de lesColonnes # . avril 2011 : ajout de lit.dar.lh et lit.dar.wd puis de go, src et sinksrc # . mars 2011 : ajout de nodup(mdata...), reduitVarsCor(), corClust(), traceCor et acp # . février 2011 : ajout de rsd # . décembre 2010 : couleurs et nombres puis pct dans traceQL # rchModeleLogistique, lesColonnes # auroc(ql,qt) # . novembre 2010 : ajout de couleurs_metaf(), modalites_metaf() et de gr() # reprise de allQT avec des valeurs NA (et donc de mdc) # ajout de pchShow(), trouvé dans example(pch) pour voir les # symboles utilisables dans plot # ajout de ucfirst (initiale en majuscule) # . octobre 2010 : ajoute de matId pour matrice identité, # matPen pour matrice de pénalité et discordance, # pairsi (la fonction pairs améliorée) # . septembre 2010 : ajout de encoding="latin1" pour source # . aout 2010 : bendist(data,col=TRUE), decritClass, lit.dac, verifSol, # analexies(txt), lit.texte(fn),versiongh() # . juin 2010 : sdmax(n,a,b), sdr(x,a,b), ifiab(x,a,b) # ajout du paramètre maxhist dans plotQTdet # bbpQT(titre,qt) # . mai 2010 : sigcodes, as.sigcode(pval) # # ################################################################# # # prévoir : nbdec pour decritQT # pctmax pour decritQL # enQL(v01,"homme femme") pour convertir en "vraie QL" au sens de R # ################################################################# # # # on charge ce fichier en écrivant # # source("statgh.r",encoding="latin1") # # avec éventuellement un chemin d'accès pour le fichier, # par exemple : # # - sous Dos on écrit / au lieu du \ habituel # source("D:/RstatDemo/statgh.r") # # - sous Linux # source("/home/gh/RstatDemo/statgh.r") # # avec internet # # source("http://forge.info.univ-angers.fr/~gh/wstat/statgh.r") # # on peut aussi utiliser # # if (!exists("cats")) { void <- capture.output( source("statgh.r",encoding="latin1") ) } # options(width=1024) # suppressPackageStartupMessages(library("gdata")) # # # ################################################################# # # Fonctions définies (extrait) : # # -- consulter plutot http://forge.info.univ-angers.fr/~gh/wstat/statghfns.php # # allQL analyse toutes les qualitatives (tris à plat et tris croisés) # allQLnonum analyse toutes les qualitatives (tris à plat) pour modalités non numériques # allQLrecap récapitulatif de tous les tris à plat # allQLtriap analyse toutes les qualitatives (tris à plat) # allQLtricr analyse toutes les qualitatives (tris croisés) # # allQT analyse toutes les quantitatives et analyse des corrélations linéaires # anaLin étude de la liaison linéaire entre 2 quantitatives # approxPoiss approxime suivant une loi de Poisson # boxplotQT trace la boite à moustaches avec sa moyenne # chi2 chi-deux d'adéquation # chi2Adeq calcule le chi-deux d'adéquation entre valeurs observées et théoriques # chi2Indep calcule le chi-deux d'indépendance pour 2 variables qualitatives # chi2IndepTable calcule le chi-deux d'indépendance pour un tric croisé # compMoy comparaison de moyennes # compMoyData comparaison de moyennes via les données (avec anova et test de Welch) # compMoyNoData comparaison de moyennes via les paramètres n,m,V et anova et test de Welch # compPourc comparaison de pourcentages # decritQT décrit une quantitative # decritQTparFacteur décrit une quantitative suivant les modalités d'une qualitative # ect calcule l'écart-type mathématique exact des données # histEffectifs affiche un histogramme via les effectifs # histProba affiche un histogramme via les probabilités # histQL affiche l'histogramme du tri à plat de la variable qualitative # identif identification probabiliste # identifgc identification probabiliste de groupes connus # moy calcule la moyenne des données # plotQT trace la courbe avec sa moyenne et sa médiane # lit.dar lit un fichier .dar (avec nom de lignes et de colonnes) # lit.dat lit un fichier .dat (avec nom de lignes seulement) # lit.dbf lit un fichier .dbf (Dbase) # lit.xls lit un fichier .xls (Excel) mais nécessite gdata # skku calcule skewness et kurtosis # triAplat effectue un tri à plat (valeurs numériques) # triAplatAvecOrdre effectue un tri à plat (valeurs numériques) et ordonne les résultats # triAplatNonum effectue un tri à plat (valeurs non numériques) # triCroise effectue un tri croisé sans marges # triCroiseAvecMarges effectue un tri croisé avec marges (en % du total) # trisCroises effectue les 4 tris croisés (effectifs, divisions ligne,colonne,total) # vvar calcule la variance mathématique exacte des données # simule # chaineEnListe # Syntaxe de ces fonctions : # allQL(tdata,tmoda,numCol) # allQLnonum(tdata,numCol,nomVars) # allQLrecap(tdata,tmoda,numCol) # allQLtriap(tdata,tmoda,numCol) # allQLtricr(tdata,tmoda,numCol) # allQT(dataMatrix,nomV,nomU) # anaLin(titreVar1,varQT1,unite1,titreVar2,varQT2,unite2) # approxPoiss(lambda,nbpoints,nbclasses) # boxplotQT(titreQt,vecteurQt) # chi2Adeq(vth,vobs,contr=FALSE) # chi2Indep(var1,var2,modal1,modal2) # chi2IndepTable(tcr,mo1="",mo2="") # compMoyData(titre,var1,var2) # compMoyNoData(titre,nb1,moy1,var1,nb2,moy2,var2) # compPourc(titre,ia,na,ib,nb) # decritQL(titreQL,nomVar,modalités,graphique,fichier_image) # decritQT(titreQT,nomVar,unité,graphique,fichier_image) # ect(nomVar) # histEffectifs(effectifs,valeurs,titre) ; # histProbas(probas,valeurs,titre) ; # histQL(titre,variableQL,modalités) ; # identif(nomv,vec,mat,affiche=1) # identifgc(fdac,fmdp,fngr) # matcor(dataMatrix,nomV,nomU) # moy(nomVar) # plotQT(nomVar,titreQT,unité="cm",tige=TRUE) # lit.dbf(nomFichierDbf) # skku(variableQT) # triAplat(titreQL,nomVar,labelMod) # triAplatAvecOrdre(titreQL,nomVar,labelMod) # triAplatNonum(titreQL,nomVar) # triCroise(titreQL1,nomVar1,labelMod1,titreQL2,nomVar2,labelMod2) # triCroiseAvecMarges(titreQL1,nomVar1,labelMod1,titreQL2,nomVar2,labelMod2) # trisCroises(titreQL1,nomVar1,labelMod1,titreQL2,nomVar2,labelMod2) # vvar(nomVar) # Exemples d'utilisation de ces fonctions : # pbioCOLQL <- 2:3 # lesm <- lstMod(c("non réponse","oui","non")) # pbioQL <- matrix(nrow=length(pbioCOLQL),ncol=3) # pbioQL[1,1] <- c("Connaissez-vous les produits biologiques ?") # pbioQL[1,2] <- c("CONNAISS") # pbioQL[1,3] <- lesm # pbioQL[2,1] <- c("Y at-il une différence entre produit biologique et produit diététique ?") # pbioQL[2,2] <- c("DIFF") # pbioQL[2,3] <-lesm # # pbio <- lit.dbf("pbio.dbf") # pbioDATA <- pbio$dbf # # allQL(pbioDATA,pbioQL,pbioCOLQL) # allQLtriap(pbioDATA,pbioQL,pbioCOLQL) # allQLrecap(pbioDATA,pbioQL,pbioCOLQL) # allQLtricr(pbioDATA,pbioQL,pbioCOLQL) # allQT(lesQT,c("AGE","POIDS","TAILLE","ALCOOL"),c("ans","kg","cm","verres")) # triAplat("Sexe de la personne",sexeElf, c("homme","femme") ) # triAplatAvecOrdre("Sexe de la personne",sexeElf, c("homme","femme") ) # triAplatNonum("Métiers ",varM) # # triCroise( # "Connaissez-vous les produits bio ?", # connaitrePbio, # c("non réponse","oui","non"), # "Différenciez-vous bio et diététique ?", # diffPbioPdiet, # c("non réponse","oui","non") # ) ; # fin de fonction triCroise # chi2Adeq( c(20,20,20,140), c(24,11,20,145) ) # chi2Adeq( 150*rep(1/6,6), c(22,21,22,27,22,36), contr=TRUE ) # chi2Indep(SEXE,ETUD,c("Homme","Femme"), c("NR","Primaire","Bepc","Bac","Supérieur")) # chi2Indep( table(SEXE,ETUD) ) # chi2IndepTable(smo,row.names(smo),colnames(smo)) # # decritQT("nombre d'élèves intégrés en 1997",integr,"personne(s)") ; # decritQT("nombre d'élèves intégrés en 1997",integr,"personne(s)",graphique=TRUE,fichier_image="elv.ps") ; # allQT(ecoles,c("INT","NPP","NEC","EFT","BUD","DAS","NPM","NOI","MSE")) ; # anaLin("Age Hommes",ageh,"ans","Age femmes",agef,"ans") # # histProba( dbinom((0:5),5,0.5) ,c(0:5),"binomiale B(5,0.5)") # histEffectifs( " Filtrages ") , c( 70 , 60 , 20 , 20 , 8 , 70 ) , 0:5 ) # # approxPoiss(10,300,15) # # compPourc(" ORDINATEURS par Région",20,102,28,98) # compMoyData( "HOMMES vs FEMMES ",c(1:8), c(2:10) ) # compMoyNoData( "AGE FR/US ",97, 5.851, 3.978, 73, 4.877, 5.642 ) # # skku( ageElf ) # skku( c(-1,2) ) # plotQT(lng,"Longueur (en acides aminés) des chaines","aa",TRUE) # boxplotQT(lng,"Longueur (en acides aminés) des chaines") # identif("CCUG1",vec1,mat1) # identifgc("xmp1.dac","xmp1.mdp","xmp1.ngr") # identifgc("rch3.dac","rch3.mdp","xmp1.ngr") # Options modifiées : options(width=180) ; options(max.print=50000) ; ################################################################# ################################################################# ## ## ## ghf FONCTIONS pour VARIABLES QUALITATIVES ## ## ## ################################################################# ################################################################# ################################################################# fql <- function() { ################################################################# cat("Pour les QL (variables qualitatives) vous pouvez utiliser :\n") cat(" decritQL() traceQL() plotQL() triAplats() histEffectifs() histProba() \n") cat(" anaTcr() traceTcr() triCroise() triCroiseAvecMarges() triCroises() \n") } ; # fin de fonction fql ################################################################# triAPlats <- function() { ################################################################# cat("Pour les tris à plat vous pouvez utiliser :\n") cat(" triAplat() triAplatAvecOrdre() triAplatNonum() \n") } ; # fin de fonction triAPlats ################################################################# decritQL <- function(titreQL,nomVar,labelMod="",graphique=FALSE,fichier_image="",ordreModalites=TRUE,ordreFreq=TRUE,barchart=FALSE,...) { ################################################################# if (missing(titreQL)) { cat(" syntaxe : decritQL(titreQL,nomVar,labelMod [ ,graphique=FALSE,fichier_image=\"\" ] )\n") cat(" exemples d'utilisation : \n") cat(" decritQL(\"SEXE dossier ELF\",sx,\"homme femme\")\n") cat(" decritQL(\"SEXE dossier Cetop\",sexeCet,\"homme femme NR\",graphique=TRUE,fichier_image=\"CET_age.png\")\n") } else { if (missing(labelMod)) { labelMod <- as.character(sort(unique(nomVar))) } if (length(labelMod)==1) { labelMod <- chaineEnListe( labelMod ) } ##if (labelMod=="") { labelMod <- as.character(sort(unique(nomVar))) } if (ordreModalites) { triAplat(paste(titreQL,"(ordre des modalités)"),nomVar,labelMod,nbDec=0) } # fin si if (ordreFreq) { triAplatAvecOrdre(paste(titreQL,"(par fréquence décroissante)"),nomVar,labelMod,nbDec=0) } # fin si if (graphique) { traceQL(titreQL,nomVar,labelMod,grfile=fichier_image,...) } if (barchart) { library(lessR) qlf <- factor( nomVar, labels=labelMod ) BarChart(qlf) } # fin si } # fin si cat("\n") return(invisible(NULL)) } ; # fin de fonction decritQL ################################################# enFacteur <- function(x,modas) { ################################################# x <- factor(x) if (!missing(modas)) { levels(x) <- modas } return(x) } # fin de fonction enFacteur ################################################################# decritQLf <- function(titreQL,nomFact,graphique=FALSE,fichier_image="",ordreModalites=TRUE,ordreFreq=TRUE,testEqui=FALSE,barchart=FALSE,nbDec=0,...) { ################################################################# if (missing(titreQL)) { cat(" syntaxe : decritQLf(titreQL,nomFacteur,labelMod [ ,graphique=FALSE,fichier_image=\"\" ] )\n") } else { labelMod <- levels(nomFact) nomVar <- as.numeric(nomFact) if (ordreModalites) { triAplat(paste(titreQL,"(ordre des modalités)"),nomVar,labelMod,nbDec=nbDec) } # fin si if (ordreFreq) { triAplatAvecOrdre(paste(titreQL,"(par fréquence décroissante)"),nomVar,labelMod,nbDec=nbDec) } # fin si if (graphique) { traceQL(titreQL,nomVar,labelMod,grfile=fichier_image,...) } if (testEqui) { nbl <- nlevels(nomFact) the <- rep( length(nomFact)/nbl,nbl) bfgr <- "" if (fichier_image!="") { bfgr <- nombase(fichier_image) } else { bgfr <- "" } # fin si chi2Adeq(vth=the, vobs=table(nomFact),contr=TRUE,graph=TRUE,basefichier=bfgr,noms=levels(nomFact)) } # finsi if (barchart) { library(lessR) dataFact <- data.frame(nomFact) BarChart(nomFact,data=dataFact) } # fin si } # fin si cat("\n") } ; # fin de fonction decritQLf ################################################################# allQL <- function(tdata,tmoda,numCol) { ################################################################# if (missing(tdata)) { cat(" syntaxe : allQL(tdata,tmoda,numCol) \n") } else { nbco <- length(numCol) tdataQL <- matrix(nrow=dim(tdata)[1],ncol=nbco) row.names(tdataQL) <- row.names(tdata) colnames(tdataQL) <- tmoda[,1] for (idc in (1:nbco)) { tdataQL[,idc] <- tdata[,numCol[idc]] } ; # fin pour print10(tdataQL) allQLtriap(tdata,tmoda,numCol) # contient le résumé : allQLrecap(tdata,tmoda,numCol) if (length(numCol)>1) { allQLtricr(tdata,tmoda,numCol) } ; # fin si } # fin si cat("\n") } ; # fin de fonction allQL ################################################################# allQLm <- function(tdata,tmoda="") { ################################################################# if (missing(tdata)) { cat(" syntaxe : allQLm(tdata,tmoda) \n") cat(" exemple : allQLm(matriceSEXE_FUMEUR,c(\"homme femme\",\"oui non\") \n") } else { nbco <- ncol(tdata) numCol <- 1:nbco print10(tdata) matmoda <- matrix(nrow=nbco,ncol=3) matmoda[,1] <- names(tdata) matmoda[,2] <- names(tdata) if (length(tmoda)==1) { for (idc in numCol) { valeurs <- sort(unique( tdata[,idc] ) ) matmoda[idc,3] <- lstMod( as.character( valeurs ) ) } # fin pour idc } else { for (idc in numCol) { matmoda[idc,3] <- lstMod( gsub(" ","!",tmoda[idc] ) ) } # fin pour idc } ; # fin de si print(matmoda) allQLtriap(tdata,matmoda,numCol) # contient le résumé : allQLrecap(tdata,tmoda,numCol) if (length(numCol)>1) { allQLtricr(tdata,matmoda,numCol) } ; # fin si } # fin si cat("\n") } ; # fin de fonction allQL ################################################################# allQLtriap <- function(tdata,tmoda,numCol) { ################################################################# allQLrecap(tdata,tmoda,numCol) cat("\n ANALYSE DE TOUTES LES VARIABLES QUALITATIVES \n") nc <- length(numCol) for (i in 1:nc) { numc <- numCol[i] varc <- tdata[,numc] titc <- paste(tmoda[i,1]," -- ", tmoda[i,2]) modc <- unlist(strsplit(tmoda[i,3],"!")) triAplat(titc,varc,modc) } ; # fin pour i } ; # fin de fonction allQLtriap ################################################################# allQLnonum <- function(tdata,numCol,nomVars) { ################################################################# nc <- length(numCol) for (i in 1:nc) { numc <- numCol[i] nomV <- nomVars[i] varc <- tdata[,numc] triAplatNonum(nomV,varc) } ; # fin pour i } ; # fin de fonction allQLnonum ################################################################# allQLrecap <- function(tdata,tmodal,numCol) { ################################################################# cat("\n TABLEAU RECAPITULATIF DES VARIABLES QUALITATIVES\n") nc <- length(numCol) # on construit le tableau des numéros de variable et mode tmodeQ <- matrix(nrow=nc,ncol=2) for (i in 1:nc) { numc <- numCol[i] varc <- tdata[,numc] titc <- tmodal[i,1] tap <- as.integer(table(varc)) tmodeQ[i,1] <- i tmodeQ[i,2] <- max(tap) } ; # fin pour i idc <- order(tmodeQ[,2],decreasing=TRUE) # affichage des correspondances court/long cat("\n Intitulé Question\n") ; cat( " -------- --------\n") ; for (i in 1:nc) { intit <- substr(paste(tmodal[i,1]," "),1,10) cat( " ",sprintf("%-10s",intit)," ",sprintf("%-70s",tmodal[i,2]),"\n") } ; # fin pour i # on peut alors construire le tableau récapitulatif # dans le bon ordre (fourni par idc) cat("\n Affichage par mode décroissant puis par effectifs décroissants\n") ; ncr <- 7 trecap <- matrix(nrow=nc,ncol=ncr) for (i in 1:nc) { j <- idc[i] numc <- numCol[j] varc <- tdata[,numc] tap <- as.integer(table(varc)) lemode <- round(100*tmodeQ[j,2]/sum(tap)) idx <- order(tap,decreasing=TRUE) modc <- unlist(strsplit(tmodal[j,3],"!")) trecap[i,1] <- paste(" ",tmodal[j,1]) trecap[i,2] <- paste(formatC(lemode,format="f",width=3,dig=0)," %") trecap[i,3] <- modc[ idx[1] ] valc <- round(100*tap[idx[2]]/sum(tap)) trecap[i,4] <- paste(formatC(valc,format="f",width=3,dig=0)," %") trecap[i,5] <- modc[ idx[2] ] if (length(idx)>2) { valc <- round(100*tap[idx[3]]/sum(tap)) trecap[i,6] <- paste(formatC(valc,format="f",width=3,dig=0)," %") trecap[i,7] <- modc[ idx[3] ] } else { trecap[i,6] <- "" trecap[i,7] <- "" } ; # fin si } ; # fin pour i colnames(trecap) <- rep(" ",ncr) rownames(trecap) <- rep(" ",nc) print(trecap,quote=FALSE) } ; # fin de fonction allQLrecap ################################################################# allQLtricr <- function(tdata,tmoda,numCol) { ################################################################# # # tous les tris croisés d'un coup ! # en hors-d'oeuvre : proposition d'un ordre de lecture # des tris croisés via les p-values du chi2 d'indépendance nc <- length(numCol) nbtcr <- nc*(nc-1)/2 if (nc>2) { cat("\n ORDRE CONSEILLE POUR LIRE LES ",nbtcr," TRIS CROISES \n\n") } odl <- matrix(nrow=nbtcr,ncol=8) lespv <- vector(length=nbtcr) alpha <- 5 nt <- 0 for (i in 1:(nc-1)) { numc1 <- numCol[i] nomc1 <- substr(paste(tmoda[i,1]," "),1,10) for (j in (i+1):nc) { nt <- nt + 1 odl[nt,1] <- numc1 odl[nt,2] <- nomc1 numc2 <- numCol[j] odl[nt,3] <- numc2 odl[nt,4] <- substr(paste(tmoda[j,1]," "),1,10) tchi <- chisq.test( table(tdata[,numc1],tdata[,numc2]), correct=TRUE) ddl <- as.integer(tchi$parameter) vc <- as.real(tchi$statistic) + 0.00 odl[nt,5] <- vc odl[nt,6] <- qchisq( 1 -alpha/100, ddl ) pv <- as.real(tchi$p.value) + 0.00 odl[nt,7] <- pv lespv[nt] <- pv odl[nt,8] <- ddl } ; # fin pour j } ; # fin pour i idc <- order(lespv) cat(" Variable 1 Variable 2 Chi2 Chi2Table ") cat(" p-value Signif. Ddl") cat("\n") for (nt in (1:nbtcr)) { nnt <- idc[ nt ] cat(" ",formatC(odl[nnt,1],format="d",width=3,dig=0)) cat(" ",odl[nnt,2]) cat(" ",formatC(odl[nnt,3],format="d",width=3,dig=0)) cat(" ",odl[nnt,4]) vc <- as.real(odl[nnt,5]) + 0.00 cat(" ",formatC(vc,format="f",width=8,dig=2)) vm <- as.real(odl[nnt,6]) + 0.00 cat(" ",formatC(vm,format="f",width=8,dig=2)) pv <- as.real(odl[nnt,7]) + 0.00 cat(" ",formatC(pv,format="f",width=15,dig=7)) cat(" ") if (pv<0.01) { cat(" ** ") } else { if (pv<0.05) { cat(" * ") } else { cat(" ") } } ; # fin de si cat(" ",formatC(odl[nnt,8],format="d",width=3,dig=0)) cat("\n") } ; # fin pour nt # puis tous les tris-croisés par ordre d'entrée for (i in 1:(nc-1)) { numc1 <- numCol[i] varc1 <- tdata[,numc1] titc1 <- tmoda[i,1] modc1 <- unlist(strsplit(tmoda[i,3],"!")) for (j in (i+1):nc) { numc2 <- numCol[j] varc2 <- tdata[,numc2] titc2 <- tmoda[j,1] modc2 <- unlist(strsplit(tmoda[j,3],"!")) triCroise(titc1,varc1,modc1,titc2,varc2,modc2) } ; # fin pour j } ; # fin pour i cat("\n") } ; # fin de fonction allQLtricr ################################################################# anaTcr <- function(titreVar1,varQL1,modaQL1,titreVar2,varQL2,modaQL2) { ################################################################# # trace le tri croisé de deux variables sous forme de 4 histogrammes # (les 2 histos de tris à plat et ceux croisés dans les deux sens) # puis analyse le tri croisé à l'aide d'un chi-deux # # exemple : # anaTcr("SEXE",sexe,"RONFLE",ronf,c("Homme","Femme"),c("ne ronfle pas","ronfle") ) if (missing(titreVar1)) { cat(" syntaxe : anaTcr(titreVar1,varQL1,modaQL1,titreVar2,varQL2,modaQL2) \n") } else { par(mfrow=c(2, 2)) traceQL(titreVar1,varQL1,modaQL1,couleur="blue") traceQL(titreVar2,varQL2,modaQL2,couleur="yellow") chi2Indep(varQL2,varQL1,modaQL2,modaQL1) traceTcr(titreVar1,varQL1,modaQL1,titreVar2,varQL2,modaQL2) traceTcr(titreVar2,varQL2,modaQL2,titreVar1,varQL1,modaQL1) par(mfrow=c(1, 1)) } # fin si cat("\n") }# fin de fonction anaTcr ################################################################# traceQL <- function(titreVar,varQL,modaQL,grfile="",txtpct=FALSE,ymax=100,couleur="blue",...) { ################################################################# # # histogramme du tri à plat en pourcentages if (missing(titreVar)) { cat(" syntaxe : traceQL(titreVar,varQL,modaQL,couleur=\"blue\",grfile=\"\") \n") } else { if (length(modaQL)==1) { modaQL <- chaineEnListe( modaQL ) } print(modaQL) if (!grfile=="") { png(grfile,width=1024,height=768) } eff <- table(varQL) pct <- 100.0*(eff/length(varQL)) pctf <- paste(sprintf("%3d",round(pct)),"%") modaQL2 <- modaQL for (idm in (1:length(modaQL))) { modaQL2[idm] <- paste("\n\n",modaQL[idm],pctf[idm],sep="\n") } # fin pour if (txtpct==FALSE) { barplot(pct,col=couleur,main=titreVar,names.arg=modaQL,space=0.8,ylim=c(0,ymax)) } else { barplot(pct,col=couleur,main=titreVar,names.arg=modaQL2,space=0.8,ylim=c(0,ymax)) pose <- barplot(pct,plot=FALSE) # la valeur 1.54 est expérimentale text(pose*1.54,pct+2,format(eff)) } # fin si if (!grfile=="") { dev.off() cat("\n vous pouvez utiliser ",grfile,"\n") } ; # fin de si } # fin si cat("\n") } # fin de fonction traceQL ################################################################# traceTcr <- function(titreVar1,varQL1,modaQL1,titreVar2,varQL2,modaQL2,...) { ################################################################# # # affiche et trace le tri croisé entre deux QL # dans le sens fourni. exemple d'utilisation : # # traceTcr("SEXE",sexe,"RONFLE",ronf,c("Homme","Femme"),c("ne ronfle pas","ronfle") ) # # on n'affiche aucun résultat statistique # la version "dans les deux sens" se nomme anaTcr # if (missing(titreVar1)) { cat(" syntaxe : traceTcr(titreVar1,varQL1,modaQL1,titreVar2,varQL2,modaQL2) \n") } else { tc <- table(varQL1,varQL2) chm <- paste(titreVar2," / ",titreVar1) nbr <- length(table(varQL1)) rgby <- c(rep("red",nbr),rep("green",nbr),rep("blue",nbr),rep("yellow",nbr),rep("brown",nbr)) modaQL3 <- modaQL2 nbm <- length(modaQL3) for (i in 1:nbm) { modaQL3[ i ] <- paste(modaQL3[ i ],"\n",paste(modaQL1,collapse=" ")) } ; # fin pour i print( modaQL3 ) barplot(tc,beside=TRUE,col=rgby,main=chm,names.arg=modaQL3,...) } # fin si cat("\n") } # fin de fonction traceTcr ################################################################# histEffectifs <- function(tit,e,v) { ################################################################# lv <- length(v) ; vmin <- min(v) vmax <- max(v) vv <- vmin:vmax vy <- rep(vv,e) ; pdv <- v brk <- c(vmin - 0.75 + 0.5*(0:(2*vmax+2))) xmin <- vmin - 1 ; xmax <- vmax + 1 ; emin <- min(e) ; emax <- max(e) ; ymin <- 0 ; nbvaly <- 4 ech <- 10**trunc(log10(emax)) ymax <- round(emax/ech) if (ech*ymax<emax) { ymax <- 0.5 + ymax } ymax <- ech*ymax ymax largy <- round(ymax/(4*ech)) largy if (ech*largy<(ymax/4)) { largy <- 0.5 + largy } largy largy <- ech*largy largy valy <- seq(0,ymax+largy,by=largy) valy hist(vy,freq = TRUE,col="red",br=brk,xlim=c(xmin,xmax),ylim=c(0,ymax+largy),axes=F, main=tit,xlab="",ylab="") ; axis(1,c(xmin:xmax),c(" ",vv," "),col.axis="blue") axis(2,valy,valy,col.axis="blue") } ; # fin de fonction histEffectifs ################################################################# histProba <- function(v,pdv,tit) { ################################################################# lv <- length(v) ; sv <- sum(v) ; w <- 100*v ; vx <- pdv ; vy <- rep(vx,w) ; minvx <- min(vx); maxvx <- max(vx); xmin <- minvx - 1 ; xmax <- maxvx + 1 ; brk <- c(-0.75+0.5*c(xmin:(2*lv-1)) ) minay <- min(v) if (minay>0) { minay <- 0 } maxay <- round(100*max(v))/100 ldvy <- c(0) hy <- 0 while (hy<maxay) { hy <- hy + 0.1 ; ldvy <- c(ldvy,hy) } if (hy>maxay){ maxay <- hy } nbax <- lv + 1 pdvemin <- min(pdv)-1 pdvemax <- max(pdv)+1 brk <- c(min(pdv) - 0.8 + 0.5*(0:(2*length(pdv)))) pdve <- c(pdvemin:pdvemax) lpdve <- c(" ",pdv," ") hist(vy,br=brk,col="red", freq = TRUE,xlim=c(xmin,xmax),ylim=100*c(minay,maxay),axes=F, main=c("Distribution de la Loi ",tit),xlab="valeurs",ylab="probabilites") axis(1,pdve,lpdve,col.axis="blue") axis(2,100*ldvy,ldvy,col.axis="blue") matH <- matrix(nrow=lv,ncol=2) ; matH[,1] <- pdv matH[,2] <- v colnames(matH) <- c("valeurs","probabilite") rownames(matH) <- rep(" ",lv) print(matH,quote=FALSE,right=TRUE) ; } ; # fin de fonction histProba ################################################################# histQL <- function(titre, vecteurQL,labelMod="") { ################################################################# # # un simple synonyme pour plotQL # plotQL(titre, vecteurQL,labelMod) } ; # fin de fonction histQL ################################################################# lstMod <- function(chMod) { ################################################################# # # fait une liste de toutes les modalités à partir # d'une chaine de caractères (les modalités sont séparées par le symbole !) # return( paste(paste(chMod,"!"),collapse="")) } ; # fin de fonction lstMod ################################################################# plotQL <- function(titre, vecteurQL,labelMod="") { ################################################################# # # un "hist" amélioré pour les QL # histEffectifs(titre,table(vecteurQL),c(min(vecteurQL),max(vecteurQL))) triAplat(titre,vecteurQL,labelMod) } ; # fin de fonction plotQL ################################################################# triAplat <- function(titreQL,nomVar,labelMod,nbDec=0) { ################################################################# if (missing(titreQL)) { cat("\n") cat(" syntaxe : triAplat( titreQL , nomVar , labelMod ) \n") ; cat(" exemple : triAplat( \"SEXE\",sx,c(\"homme\",\"femme\") ) \n") ; } else { cat("TRI A PLAT DE : ",titreQL,"\n\n") ; if (length(labelMod)==1) { labelMod <- chaineEnListe( labelMod ) } nbv <- length(nomVar) nbNA <- sum(is.na(nomVar)) if (nbNA==0) { cat(" aucune valeur manquante sur",nbv,"\n\n") } else { pctNA <- sprintf("%6.2f",100*nbNA/nbv) cat(nbNA,"valeurs manquantes sur",nbv,"soit",pctNA,"%\n\n") } # finsi as.vector(table(nomVar)) -> vetcp ; # effectifs length(vetcp) -> nbmod ; # nombre de valeurs sum(vetcp) -> efftot ; # effectif total cumsum(vetcp) -> effcum ; # effectifs cumulés 100*vetcp/efftot -> vftc ; # fréquences % if (nbDec==0) { round(vftc) -> vftcp ; # fréquences arrondies en % round(cumsum(vftc)) -> vdcum ; # cumul } else { round(vftc,nbDec) -> vftcp ; # fréquences arrondies en % round(cumsum(vftc),nbDec) -> vdcum ; # cumul } # fin si matrix(nrow=4,ncol=nbmod+1) -> mrtcp ; mrtcp[1,(1:nbmod)] <- vetcp ; mrtcp[1, nbmod+1] <- efftot ; mrtcp[2,(1:nbmod)] <- effcum ; mrtcp[2, nbmod+1] <- efftot ; mrtcp[3,(1:nbmod)] <- vftcp ; mrtcp[3, nbmod+1] <- sum(vftcp) ; mrtcp[4,(1:nbmod)] <- vdcum ; mrtcp[4, nbmod+1] <- sum(vftcp) if (length(labelMod)==1) { labelMod <- unlist( strsplit(labelMod," ") ) } colnames(mrtcp) <- c(labelMod," Total") ; rownames(mrtcp) <- c(" Effectif "," Cumul Effectif"," Frequence (en %)"," Cumul fréquences") ; if (nbDec>0) { mrtcp[3,] <- sprintf(paste("%6.",nbDec,"f",sep=""),as.numeric(mrtcp[3,])) mrtcp[4,] <- sprintf(paste("%6.",nbDec,"f",sep=""),as.numeric(mrtcp[3,])) } # fin si print(mrtcp,quote=FALSE,right=TRUE) ; } ; # fin de si cat("\n") ; } # fin de fonction triAplat ################################################################# triaplat <- function(titreQL,nomVar,labelMod=0,digits=2,...) { ################################################################# cats(paste("TRI A PLAT DE : ",titreQL)) ; library(questionr) tap <- questionr::freq(nomVar, cum = TRUE, sort = "dec", total = TRUE,digits=digits) if (!missing(labelMod)) { if (length(labelMod)==1) { labelMod <- chaineEnListe( labelMod ) } row.names(tap)[1:length(labelMod)] <- paste( labelMod," (",row.names(tap)[1:length(labelMod)], ")", sep= "") } # fin si tap$cum <- cumsum(tap$n) return(tap) } # fin de fonction triaplat ################################################################# triAplatAvecOrdre <- function(titreQL,nomVar,labelMod,nbDec=0) { ################################################################# cat("VARIABLE : ",titreQL,"\n\n") ; as.vector(table(nomVar)) -> vetcp ; # effectifs length(vetcp) -> nbmod ; # nombre de valeurs sum(vetcp) -> efftot ; # effectif total cumsum(vetcp) -> effcum ; # effectif total 100*vetcp/efftot -> vftc ; # fréquences % if (nbDec==0) { round(vftc) -> vftcp ; # fréquences arrondies en % round(cumsum(vftc)) -> vdcum ; # cumul } else { round(vftc,nbDec) -> vftcp ; # fréquences arrondies en % round(cumsum(vftc),nbDec) -> vdcum ; # cumul } # finsi matrix(nrow=4,ncol=nbmod+1) -> mrtcp ; if (length(labelMod==1)) { labelMod <- unlist( strsplit(labelMod," ") ) } # on trie ... idx <- order( vetcp, decreasing=TRUE) mrtcp[1,(1:nbmod)] <- vetcp[idx] ; mrtcp[1, nbmod+1] <- efftot ; mrtcp[2,(1:nbmod)] <- cumsum(vetcp[idx]) ; mrtcp[2, nbmod+1] <- efftot ; mrtcp[3,(1:nbmod)] <- vftcp[idx] ; round(cumsum(vftc[idx])) -> vdcum ; # cumul mrtcp[3, nbmod+1] <- sum(vftcp) ; mrtcp[4,(1:nbmod)] <- vdcum ; mrtcp[4, nbmod+1] <- sum(vftcp) colnames(mrtcp) <- c(labelMod[idx]," Total") ; rownames(mrtcp) <- c(" Effectif "," Cumul Effectif"," Frequence (en %)"," Cumul fréquences") ; if (nbDec>0) { mrtcp[3,(1:nbmod)] <- vftcp[idx] ; mrtcp[3, nbmod+1] <- sum(vftcp) ; mrtcp[3,] <- sprintf(paste("%6.",nbDec,"f",sep=""),as.numeric(mrtcp[3,])) mrtcp[4,(1:nbmod)] <- vdcum ; mrtcp[4, nbmod+1] <- sum(vftcp) mrtcp[4,] <- sprintf(paste("%6.",nbDec,"f",sep=""),as.numeric(mrtcp[3,])) } # fin si print(mrtcp,quote=FALSE,right=TRUE) ; cat("\n") ; } # fin de fonction triAplatAvecOrdre ################################################################# triAplatNonum <- function(titreQL,nomVar) { ################################################################# cat("\n QUESTION : ",titreQL,"\n\n") ; as.vector(table(nomVar)) -> vetcp ; # effectifs length(vetcp) -> nbmod ; # nombre de valeurs sum(vetcp) -> efftot ; # effectif total round(100*vetcp/efftot) -> vftcp ; # fréquences en % matrix(nrow=2,ncol=nbmod+1) -> mrtcp ; mrtcp[1,(1:nbmod)] <- vetcp ; mrtcp[1, nbmod+1] <- efftot ; mrtcp[2,(1:nbmod)] <- vftcp ; mrtcp[2, nbmod+1] <- sum(vftcp) ; colnames(mrtcp) <- c(levels(nomVar)," Total") ; rownames(mrtcp) <- c(" Effectif "," Fréquence (en %)") ; print(mrtcp,quote=FALSE,right=TRUE) ; cat("\n") ; } # fin de fonction triAplatNoNum ################################################################# triCroiseSansMarges <- function(titreQL1,nomVar1,labelMod1,titreQL2,nomVar2,labelMod2) { ################################################################# if (missing(titreQL1)) { cat("\n") cat(" syntaxe : triCroiseSansMarges( titreQL1 , nomVar1 , labelMod1,titreQL2,nomVar2,labelMod2) \n") ; cat(" exemple : triCroiseSansMarges( \"SEXE\",sx,c(\"homme\",\"femme\"), \"ETUD\",etud,metud ) \n") ; return(-1) } # fin si cat("\n TRI CROISE DES QUESTIONS : \n ",titreQL1," (en ligne) \n ",titreQL2," (en colonne)\n") ; cat("Effectifs\n") ; table(nomVar1,nomVar2) -> mtcp ; rownames(mtcp) <- labelMod1 ; colnames(mtcp) <- labelMod2 ; print(mtcp,quote=FALSE) ; cat("\n% du total\n") ; mtcp <- round(100*mtcp/sum(mtcp)) ; print(mtcp,quote=FALSE) ; } # fin de fonction triCroiseSansMarges ################################################################# ajouteTotaux <- function(tableau) { ################################################################# avecTotaux <- addmargins(tableau) colnames(avecTotaux)[ ncol(avecTotaux)] <- "Total" row.names(avecTotaux)[nrow(avecTotaux)] <- "Total" return(avecTotaux) } # fin de fonction ajouteTotaux ################################################################# triCroise <- function(titreQL1,nomVar1,labelMod1,titreQL2,nomVar2,labelMod2,graphique=FALSE,grfile="") { ################################################################# if (missing(titreQL1)) { cat("\n") cat(" syntaxe : triCroise( titreQL1 , nomVar1 , labelMod1,titreQL2,nomVar2,labelMod2,graphique=FALSE,grfile) \n") ; cat(" exemple : triCroise( \"SEXE\",sx,c(\"homme\",\"femme\"), \"ETUD\",etud,metud ) \n") ; cat(" si graphique est TRUE, on effectue le test complet du CHI2 via anaTcr()\n") ; } else { cat("\nTRI CROISE DES QUESTIONS : \n ",titreQL1," (en ligne) \n ",titreQL2," (en colonne)\n") ; if (!grfile=="") { png(grfile,width=1024,height=768) ; graphique = TRUE } mtcp <- table(nomVar1,nomVar2) ; md <- dim(mtcp) ; gmd <- dim(mtcp) + 1 ; tmtcp <- matrix(nrow=md[1],ncol=md[2]) ; gmtcp <- matrix(nrow=gmd[1],ncol=gmd[2]) ; if (length(labelMod1)==1) { labelMod1 <- unlist( strsplit(labelMod1," ") ) } if (length(labelMod2)==1) { labelMod2 <- unlist( strsplit(labelMod2," ") ) } cat("Effectifs\n") ; tmtcp[(1:md[1]),(1:md[2])] <- mtcp[(1:md[1]),(1:md[2])] rownames(tmtcp) <- labelMod1 colnames(tmtcp) <- labelMod2 print(tmtcp,quote=FALSE) ; cat("Effectifs avec totaux\n") ; print(ajouteTotaux(tmtcp)) gmtcp[1:md[1],1:md[2]] <- mtcp ; gmtcp[gmd[1] ,1:md[2]] <- table(nomVar2) ; gmtcp[1:md[1], gmd[2]] <- table(nomVar1) ; tg <- sum(mtcp) ; gmtcp[gmd[1] , gmd[2]] <- tg ; rownames(gmtcp) <- c(labelMod1,"TOTAL") ; colnames(gmtcp) <- c(labelMod2,"TOTAL") ; cat("\nValeurs en % du total\n") ; mtcp <- round(100*mtcp/tg) ; gmtcp[1:md[1],1:md[2]] <- mtcp ; gmtcp[gmd[1] ,1:md[2]] <- round(100*table(nomVar2)/tg) ; gmtcp[1:md[1], gmd[2]] <- round(100*table(nomVar1)/tg) ; gmtcp[gmd[1] , gmd[2]] <- 100 ; print(gmtcp,quote=FALSE) ; if (graphique) { anaTcr(titreQL1,nomVar1,labelMod1,titreQL2,nomVar2,labelMod2) } ; # fin de si if (!grfile=="") { dev.off() cat("\n vous pouvez utiliser ",grfile,"\n") } ; # fin de si } # fin de si } # fin de fonction triCroise ######################################################################### triCroiseBC <- function(ql1,ql2,decPct=3,nomql1,nomql2,nomsMods=NULL) { ######################################################################### # un tric croisé avec comptage des BC (bien classés) sur la diagonale tcr <- table(ql1,ql2) # tri croisé nbl <- nrow(tcr) nbc <- nrow(tcr) dfc <- matrix(nrow=nbl+2,ncol=nbc+2) dfc[(1:nbl),(1:nbc)] <- tcr # ajout des totaux en ligne et colonne row.names(dfc) <- c(unlist(labels(table(ql1))) ,"Total","%BC") colnames(dfc) <- c(unlist(labels(table(ql2))),"Total","%BC") bc <- sum(diag(tcr)) dfc[(nbl+2) ,(nbc+2)] <- bc dfc[(nbl+1) ,(1:nbc)] <- colSums(tcr) dfc[(1:nbl) ,(nbc+1)] <- rowSums(tcr) dfc[(nbl+1) ,(nbc+1)] <- sum(tcr) # ajout des % BC eps <- 10**(-7) for (idl in (1:nbl)) { dfc[(nbl+2),idl] <- round(dfc[idl,idl]/dfc[(nbl+1),idl]+eps,decPct) dfc[idl,(nbc+2)] <- round(dfc[idl,idl]/dfc[idl,(nbc+1)],decPct) } # fin pour idl if (length(nomsMods)==0) { nomsMods <- row.names(dfc) } # finsi discordance(score1=ql1,score2=ql2,matpond=matPen(taille=nbl,opt="unif"),modalites=nomsMods) cat(bc," bien classés sur ",sum(tcr),"pourcentage global BC",round(100*dfc[(nbl+2) ,(nbc+2)]/dfc[(nbl+1) ,(nbc+1)],decPct),"% \n") catn() return(dfc) } # fin de fonction triCroiseBC ################################################################# ################################################################# ## ## ## ghf FONCTIONS pour VARIABLES QUANTITATIVES ## ## ## ################################################################# ################################################################# ################################################################# fqt <- function() { ################################################################# cat("Pour les QT (variables quantitatives) vous pouvez utiliser :\n") cat(" decritQT() boxplotQT() plotQT() allCalcQT() decritQTparFacteur() \n") cat(" anaLin() traceLin() mdc() allQT() allQTdf() \n") } ; # fin de fonction fqt ################################################################# allQT <- function(dataMatrix,nomV="",nomU="",graphique=FALSE,grfile="",details=TRUE){ ################################################################# # # on passe en revue toutes les variables QT (quantitatives) # avec calculs de m,s,s/ma etc. puis de la matrice des ccl # (coefficients de corrélation linéiares) avec la liste # de ces ccl par ordre décroissant ; on donne enfin # les ccl pour la forte corrélation avec production d'un # graphique postscript pour cette plus forte corrélation # # les données sont une matrice numérique (ligne 1 numérique, # colonne 1 numérique car les identifiants de ligne et de # colonne doivent avoir été transmis à rownames et colnames # # nomV est le nom des variables # nomU est le nom des unités associées aux variable # # exemple d'utilisation : # # allQT(lesQT,c("AGE","POIDS","TAILLE","ALCOOL"),c("ans","kg","cm","verres")) # vins <- lit.dbf("vins.dbf")$dbf[,-1] # allQT(vins,colnames(vins),rep("hhl",length(colnames(vins)))) if (missing(dataMatrix)) { cat(" syntaxe : allQT(dataMatrix,nomV,nomU,graphique=FALSE,grfile=\"\",details=TRUE) \n") } else { # pour l'ajustement des noms de variable lngmax <- max(nchar(names(dataMatrix))) fmtS <- paste("%-",lngmax,"s",sep="") dataMatrix <- ajusteNomsColonnes(dataMatrix) if (length(nomV)==1) { if (nomV=="") { nomV <- colnames(dataMatrix) } } # finsi if (length(nomV)==1) { nomV <- chaineEnListe( nomV ) } if (length(nomU)==1) { nomU <- chaineEnListe( nomU ) } dm <- dim(dataMatrix) ; nl <- dm[1] nc <- dm[2] resMat <- matrix(nrow=nc,ncol=9) # identifiants pour la matrice des résultats rownames(resMat) <- rep(" ",nc) ; colnames(resMat) <- c(" Num "," Nom "," Taille"," Moyenne"," Unite"," Ecart-type"," Coef. de var."," Minimum"," Maximum") tabCdv <- vector(length=nc) for (i in 1:nc) { vorg <- dataMatrix[,i] v <- vorg[!is.na(vorg)] resMat[i,1] <- i resMat[i,2] <- sprintf(fmtS,nomV[i]) resMat[i,3] <- length(v) mv <- mean(v) vv <- var(v) resMat[i,4] <- formatC(mv,"f",width=10,dig=3) resMat[i,5] <- nomU[i] resMat[i,6] <- formatC( sqrt(vv),"f",width=10,dig=3) lecdv <- abs(100*(sqrt(vv)/mv)) tabCdv[i] <- lecdv fcdv <- sprintf("%6.2f",lecdv) resMat[i,7] <- sprintf("%-8s %%",fcdv) resMat[i,8] <- min(v) resMat[i,9] <- max(v) # formatage éventuel resMat[i,8] <- formatC(round(1000*as.numeric(resMat[i,8]))/1000,"f",width=9,dig=3) resMat[i,9] <- formatC(round(1000*as.numeric(resMat[i,9]))/1000,"f",width=9,dig=3) } # fin pour i # tri par cdv décroissant tabCdv <- tabCdv * (-1) odx <- order(tabCdv) ; ordMat <- matrix(nrow=nc,ncol=9) ; rownames(ordMat) <- rep(" ",nc) ; colnames(ordMat) <- colnames(resMat) for (i in 1:nc) { ordMat[i,] <- resMat[ odx[i], ] } # fin pour i # tri par moyenne décroissante moy <- as.numeric(resMat[,4]) moy <- moy * (-1) odx <- order(moy) ; moyMat <- matrix(nrow=nc,ncol=9) ; rownames(moyMat) <- rep(" ",nc) ; colnames(moyMat) <- colnames(resMat) for (i in 1:nc) { moyMat[i,] <- resMat[ odx[i], ] } # fin pour i # affichages ##cat("\nDonnées\n") ; ##print(dataMatrix,rowlab=rep(" ",nl),quote=FALSE,right=TRUE) ; # affichage éventuel des dix premières lignes de données if (details) { print10(dataMatrix) } cat("\nDescription des ",ncol(dataMatrix)," variables statistiques par cdv décroissant\n") ; print(ordMat,quote=FALSE,right=TRUE) ; if (details) { cat("\nPar ordre d'entrée\n") ; print(resMat,quote=FALSE,right=TRUE) ; cat("\nPar moyenne décroissante\n") ; print(moyMat,quote=FALSE,right=TRUE) ; # matrice des corrélations lesData <- ajusteNomsColonnes(dataMatrix) mdc(lesData,colnames(lesData),meilcor=TRUE) # graphique par paires éventuel if (graphique) { if (!grfile=="") { png(grfile,width=1024,height=768) ; graphique = TRUE } pairsi(dataMatrix) if (!grfile=="") { cat("\n vous pouvez utiliser ",grfile,"\n") dev.off() } ; # fin de si } # fin si sur graphique } # fin si } # fin si cat("\n") } ; # fin de fonction allQT ################################################################# ajusteNomsColonnes <- function(dataMatrix) { ################################################################# # # ajustement des noms de variable à la longueur du plus long nom # attention : il y a alors des espaces dans les noms de variables # # s'utilise par df <- ajusteNomsColonnes(df) lngmax <- max(nchar(names(dataMatrix))) fmtS <- paste("%-",lngmax,"s ",sep="") colnames(dataMatrix) <- sprintf(fmtS,colnames(dataMatrix)) return(dataMatrix) } ; # fin de fonction ajusteNomsColonnes ################################################################# allQTdf <- function(dataFrame,nomU="",details=TRUE,univar=TRUE) { ################################################################# if (missing(nomU)) { nomUnite <- rep("?",dim(dataFrame)[2]) ; } else { nomUnite <- nomU if (length(nomU)==1) { nomUnite <- chaineEnListe( nomUnite ) } } ; # fin si allQT(dataFrame,nomV=names(dataFrame),nomU=nomUnite,details=details) if (univar) { lesNoms <- colnames(dataFrame) pairs(dataFrame) for (idv in seq(lesNoms)) { nomvar <- lesNoms[idv] imgPng <- paste(nomvar,".png",sep="") decritQT(toupper(nomvar),dataFrame[,nomvar],nomUnite[idv],TRUE,imgPng) } # fin si } # fin si } ; # fin de fonction allQTdf ################################################################# milieu <- function(x) { ################################################################# return( (min(x)+max(x)) / 2 ) # surtout pas mean( min(x), max(x) ) ! ################################################################# } # fin de fonction milieu ################################################################# allQT2 <- function(dataMatrix,nomV,nomU) { ################################################################# # # comme allQT mais avec cl, cov, comed et cdl # dm <- dim(dataMatrix) ; nl <- dm[1] nc <- dm[2] resMat <- matrix(nrow=nc,ncol=10) # identifiants pour la matrice des résultats rownames(resMat) <- rep(" ",nc) ; cn <- c(" Nom "," Num "," Taille"," Moyenne"," Unite") cn <- c(cn," Ecart-type"," Coef. de var."," Coef. de lat."," Minimum"," Maximum") colnames(resMat) <- cn tabCdv <- vector(length=nc) for (i in 1:nc) { v <- dataMatrix[,i] resMat[i,1] <- i resMat[i,2] <- sprintf("%-8s",nomV[i]) resMat[i,3] <- length(v) mv <- mean(v) vv <- vvar(v) resMat[i,4] <- formatC(mv,"f",width=9,dig=3) resMat[i,5] <- nomU[i] resMat[i,6] <- formatC( sqrt(vv),"f",width=9,dig=3) lecdv <- 100*(sqrt(vv)/mv) tabCdv[i] <- lecdv fcdv <- sprintf("%6.2f",lecdv) resMat[i,7] <- sprintf("%-8s %%",fcdv) fclv <- sprintf("%6.2f",cl(v)) resMat[i,8] <- sprintf("%-8s %%",fclv) resMat[i,9] <- min(v) resMat[i,10] <- max(v) # formatage éventuel resMat[i,9] <- formatC(round(1000*as.numeric(resMat[i,9]))/1000,"f",width=9,dig=3) resMat[i,10] <- formatC(round(1000*as.numeric(resMat[i,10]))/1000,"f",width=9,dig=3) } # fin pour i # tri par cdv décroissant tabCdv <- tabCdv * (-1) odx <- order(tabCdv) ; ordMat <- matrix(nrow=nc,ncol=10) ; rownames(ordMat) <- rep(" ",nc) ; colnames(ordMat) <- colnames(resMat) for (i in 1:nc) { ordMat[i,] <- resMat[ odx[i], ] } # fin pour i # tri par moyenne décroissante moy <- as.numeric(resMat[,4]) moy <- moy * (-1) odx <- order(moy) ; moyMat <- matrix(nrow=nc,ncol=10) ; rownames(moyMat) <- rep(" ",nc) ; colnames(moyMat) <- colnames(resMat) for (i in 1:nc) { moyMat[i,] <- resMat[ odx[i], ] } # fin pour i # affichages cat("\nDonnées\n") ; print(dataMatrix,rowlab=rep(" ",nl),quote=FALSE,right=TRUE) ; cat("\nPar cdv décroissant\n") ; print(ordMat,quote=FALSE,right=TRUE) ; cat("\nPar ordre d'entrée\n") ; print(resMat,quote=FALSE,right=TRUE) ; cat("\nPar moyenne décroissante\n") ; print(moyMat,quote=FALSE,right=TRUE) ; # matrice des corrélations mdc(dataMatrix,nomV,meilcor=TRUE) } ; # fin de fonction allQT2 ################################################################# panel.cor <- function(x, y, digits=2, prefix="", cex.cor, ...) { ################################################################# #usr <- par("usr"); on.exit(par(usr)) #par(usr = c(0, 1, 0, 1)) r <- cor(x, y,use="pairwise.complete.obs") #txt <- format(c(r, 0.123456789), digits=digits)[1] #txt <- paste(prefix, txt, sep="") #txt2 <- format(c(abs(r), 0.123456789), digits=digits)[1] #"txt2 <- paste(prefix, txt2, sep="") pval <- as.sigcode(cor.test(x, y,use="pairwise.complete.obs")$p.value) if (missing(cex.cor)) { cex.cor <- 5 } aff <- paste(sprintf("%4.2f",r),pval,sep="") #if (missing(cex.cor)) cex.cor <- 0.8/strwidth(txt2) ncex.cor <- cex.cor * abs(r) / 1.9 if (ncex.cor < 1) { ncex.cor <- 1 } px <- milieu(x) py <- milieu(y) #text( px, py, labels=aff , cex = ncex.cor ) legend(x="center", legend=aff , cex = ncex.cor,bty="n" ) #cat(" r ",r," pval ",pval," ncex ",ncex.cor,"\n") #attends() } ; # fin de fonction panel.cor ################################################################# panel.cor2 <- function(x, y, digits=2, prefix="", cex.cor, ...) { ################################################################# usr <- par("usr"); on.exit(par(usr)) par(usr = c(0, 1, 0, 1)) r <- cor(x, y,use="pairwise.complete.obs") txt <- format(c(r, 0.123456789), digits=digits)[1] txt <- paste(prefix, txt, sep="") txt2 <- format(c(abs(r), 0.123456789), digits=digits)[1] txt2 <- paste(prefix, txt2, sep="") pval <- as.sigcode(cor.test(x, y,use="pairwise.complete.obs")$p.value) if (missing(cex.cor)) { fcex <- 0.8/strwidth(txt2) #cat(" fcex vaut ",fcex,"\n") } #attends() if (missing(cex.cor)) cex.cor <- 0.8/strwidth(txt2) #text(0.5, 0.5, paste(txt,pval,sep="") , cex = cex.cor * abs(r) / 1.4 ) } ; # fin de fonction panel.cor2 ################################################################# panel.corpvalue <- function(x, y, digits=2, prefix="", cex.cor, ...) { ################################################################# usr <- par("usr"); on.exit(par(usr)) par(usr = c(0, 1, 0, 1)) r <- cor(x, y,use="pairwise.complete.obs") txt <- format(c(r, 0.123456789), digits=digits)[1] txt <- paste(prefix, txt, sep="") pval <- as.sigcode(cor.test(x, y,use="pairwise.complete.obs")$p.value) txt2 <- format(c(abs(r), 0.123456789), digits=digits)[1] txt2 <- paste(prefix, txt2, sep="") if (missing(cex.cor)) cex.cor <- 0.8/strwidth(txt2) text(0.5, 0.5, pval, cex = cex.cor * abs(r) ) } ; # fin de fonction panel.corpvalue ################################################################# panel.pointsreg <- function(x, y, digits=2, prefix="", cex.cor, ...) { ################################################################# points(x,y,pch=19) abline(lm(y~x),col="red") } ; # fin de fonction panel.pointsreg ################################################################# recadrage <- function(v,vmin=0,vmax=4,out=0,rounding=TRUE) { ################################################################# # on arrondit ; si v<=vmin, on met vmin ; si v>=vmax, on met vmax # si out=1, on affiche le nombre et les valeurs recadrées if (out==1) { nbinf <- sum(v<vmin) cat("Nombre de valeurs < ",vmin," : ",sprintf("%4d",nbinf),"\n") if (nbinf>0) { print(v[v<vmin]) } nbsup <- sum(v>vmax) cat("Nombre de valeurs > ",vmax," : ",sprintf("%4d",nbsup),"\n") if (nbsup>0) { print(v[v>vmax]) } } # finsi newY <- v if (rounding) { newY <- round(v) } #table(newY) newY <- ifelse(newY<vmin,vmin,newY) #table(newY) newY <- ifelse(newY>vmax,vmax,newY) #table(newY) return(newY) } # fin de fonction recadrage ################################################################# pairsi <- function(lesVar,opt=2,...) { ################################################################# if (opt==1) { pairs(lesVar,lower.panel=panel.pointsreg,...) } ; # fin si if (opt==2) { pairs(lesVar,upper.panel=panel.cor,lower.panel=panel.pointsreg,...) } ; # fin si if (opt==3) { pairs(lesVar,upper.panel=panel.cor,...) } ; # fin si ################################################################# } ; # fin de fonction pairsi ################################################################# anaLin <- function(titreVar1,varQT1,unite1="?",titreVar2,varQT2,unite2="?",graphique=FALSE,grfile="") { ################################################################# # affiche et trace la corrélation linéaire entre deux QT # dans les deux sens, avec les statistiques détaillées. exemple d'utilisation : # # anaLin("TAILLE",taille,"cm","POIDS",poi,"cm",TRUE,"tp.png") # if (missing(titreVar1)) { cat(" syntaxe : analin(titreVar1,varQT1,unite1=\"?\",titreVar2,varQT2,unite2=\"?\",graphique=FALSE,grfile=\"\") \n") } else { cat("\n ANALYSE DE LA LIAISON LINEAIRE ENTRE ",titreVar1," ET ", titreVar2,"\n\n") cdc <- cor(varQT1,varQT2) cat("\n coefficient de corrélation de Pearson : ",cdc," donc R2 = ",cdc*cdc,"\n\n") fcdc <- sprintf("%5.2f",cdc) cat(" p-value associée : ",cor.test(varQT1,varQT2)$p.value,"\n\n") if (graphique) { if (!grfile=="") { png(grfile,width=1600,height=1200) ; graphique = TRUE } idx <- order(varQT1) par(mfrow=c(2, 2)) plot(varQT1[idx],main=titreVar1,col="blue",xlab="",ylab="") plot(varQT2[idx],main=titreVar2,col="blue",xlab="",ylab="") #plotQT(titreVar1,varQT1,unite1,tigef=FALSE) #plotQT(titreVar2,varQT2,unite2,tigef=FALSE) traceLin(titreVar1,varQT1,titreVar2,varQT2,TRUE) traceLin(titreVar2,varQT2,titreVar1,varQT1,TRUE) if (!grfile=="") { cat("\n vous pouvez utiliser ",grfile,"\n") dev.off() } ; # fin de si par(mfrow=c(1, 1)) } # fin si cat("\n") } # fin si } ; # fin de fonction anaLin ################################################################# analyseRegression <- function(titre,xi,yi,graphiques=TRUE,interactif=TRUE,basegr="",nbLigMax=10) { ################################################################# if (missing(yi)) { cat("syntaxe : analyseRegression(titre,xi,yi,graphiques=TRUE,interactif=TRUE,basegr=\"\") \n") ; cat("exemples : resRegLin <- analyseRegression(\"Prix d'appartement en fonction de la surface\",surf, prix) \n") cat(" resreg <- analyseRegression(titre=\"Anscombe 4 \",xi=anscombe$x4,yi=anscombe$y4,graphiques=TRUE,basegr=\"anscombe4_\",interactif=FALSE) \n\n") cat(" la fonction renvoie une liste avec le modèle, les coefficients (avec IC) et le tableau des indicateurs (résidus, leviers...)\n") ; cat(" si basegr est non nul, on produit 9 graphiques PNG au lieu de les afficher.\n") ; return() } # fin si if (graphiques) { if (interactif) { sovAsk <- par("ask") par(ask=TRUE) } # fin si if (basegr!="") { numgr <- 0 } # fin si } # fin si n <- length(yi) cats(paste("Analyse de la régression \"",titre,"\" sur ",n," valeurs",sep="")) cats("Affichage de summary(lm(yi~xi) :","-") print(summary(lm(yi~xi))) cats("Résultats de la régression :","-") rcorr <- cor(xi,yi) pv <- cor.test(xi,yi)$p.value cat("\nvaleur de R : rho =",sprintf("%0.3f",rcorr)," donc R2= ",sprintf("%0.3f",rcorr**2)," ; p-value : ",sprintf("%0.3f",pv)," ",as.sigcode(pv),"\n") cat("\ncoefficients de la régression et intervalles de confiance à 95 %\n") ; ml <- lm(yi~xi) vcoef <- cbind( summary(ml)$coefficients,confint(ml)) print( round(vcoef,3) ) cats("Résidus et points remarquables","-") # étude des résidus et autres indicateurs de qualité yihat <- ml$fitted.values # valeurs recalculées ei <- residuals(ml) # résidus lsf <- lsfit(x=xi,y=yi) lsd <- ls.diag(lsf) lev <- hatvalues(ml) # leviers rsu <- rstandard(ml) # résidu studentisé rst <- rstudent(ml) # # rstudent dfi <- lsd$dfits # dfits #dfb <- dfbetas(ml) coo <- cooks.distance(ml) tind <- cbind(1:length(xi),xi,yi,yihat,ei,rsu,lev,rst,dfi,coo) row.names(tind) <- rep("",nrow(tind)) colnames(tind) <- c("obs","xi","yi","yi_chapeau","résidu","résidu_studentisé","levier","rstudent","dfits","cook_dist") cat("\nDébut de ces résultats, ",nbLigMax," lignes au maximum seront affichées\n") print(head(tind)) ## points remarquables cat("\n") # résidu(s) seu <- 0 flt <- (abs(ei)>=seu) | (is.na(ei)) nb <- sum(flt) if (nb>0) { cat(nb,"résidu(s) fort(s) >= seuil = ",seu,"\n") if(nb>nbLigMax) { cat(" on n'affiche que les ",nbLigMax,"premiers résidus \n") } # fin si tindRes <- tind[flt,] # on trie idx <- order(abs(tindRes[,6]),decreasing=TRUE) nbLigAff <- min(nb,nbLigMax) print(head(round(tindRes[idx,],3),n=nbLigAff)) } else { cat("aucun résidu fort >= seuil = ",seu,"\n") } # fin si cat("\n") # leviers seu <- 3/n flt <- (abs(lev)>=seu) | (is.na(lev)) nb <- sum(flt) if (nb>0) { cat(nb,"levier(s) important(s) >= seuil 3/n =",seu,"\n") if(nb>nbLigMax) { cat(" on n'affiche que les ",nbLigMax,"premiers leviers\n") } # fin si tindLev <- tind[flt,] # on trie idx <- order(abs(tindLev[,7]),decreasing=TRUE) nbLigAff <- min(nb,nbLigMax) print(head(round(tindLev[idx,],3),n=nbLigAff)) } else { cat("aucun levier important >= seuil 3/n =",seu,"\n") } # fin si cat(" autres seuils possibles : 2/n = ",round(2/n,3)," Hoaglin et Welsch (1978 ) ; 0.5 Huber (1987) \n") cat("\n") # résidu(s) studentisé(s) seu <- 2 flt <- (abs(rsu)>=seu) | (is.na(rsu)) nb <- sum(flt) if (nb>0) { cat(nb,"résidu(s) studentisé(s) fort(s) >= seuil = ",seu,"\n") if(nb>nbLigMax) { cat(" on n'affiche que les ",nbLigMax,"premiers résidus studentisés\n") } # fin si tindRes <- tind[flt,] # on trie idx <- order(abs(tindRes[,6]),decreasing=TRUE) nbLigAff <- min(nb,nbLigMax) print(head(round(tindRes[idx,],3),n=nbLigAff)) } else { cat("aucun résidu studentisé fort >= seuil = ",seu,"\n") } # fin si cat("\n") # observation(s) mal reconstituée(s) seu <- qt(0.975,n-3) flt <- (abs(rsu)>=seu) | (is.na(rst)) nb <- sum(flt) if (is.na(nb)) { nb <- sum(is.na(flt)) } if (nb>0) { cat(nb,"observation(s) mal reconstituée(s), rstudent >= seuil = ",seu,"\n") if(nb>nbLigMax) { cat(" on n'affiche que les ",nbLigMax," premières observation(s) mal reconstituée(s)\n") } # fin si tindOmr <- tind[flt,] # on trie idx <- order(abs(tindOmr[,6]),decreasing=TRUE) nbLigAff <- min(nb,nbLigMax) print(head(round(tindOmr[idx,],3),n=nbLigAff)) } else { cat("aucune observation mal reconstituée, rstudent >= seuil = ",seu,"\n") } # fin si cat("\n") # dfits significatif(s) seu <- 2*sqrt(2/n) flt <- (abs(dfi)>=seu) | (is.na(dfi)) nb <- sum(flt) if (nb>0) { cat(nb,"dfits significatif(s) >= seuil 2*racine(2/n) = ",seu,"\n") if(nb>nbLigMax) { cat(" on n'affiche que les ",nbLigMax," premiers dfits significatifs\n") } # fin si tindDfit <- tind[flt,] # on trie idx <- order(abs(tindDfit[,9]),decreasing=TRUE) nbLigAff <- min(nb,nbLigMax) print(head(round(tindDfit[idx,],3),n=nbLigAff)) } else { cat("aucun dfit significatif >= seuil 2*racine(2/n) li= ",seu,"\n") } # fin si cat("\n") # distance(s) de cook seu <- 4/n flt <- (abs(coo)>=seu) | (is.na(coo)) nb <- sum(flt) if (nb>0) { cat(nb,"distance(s) de cook >= seuil = ",seu,"\n") if(nb>nbLigMax) { cat(" on n'affiche que les ",nbLigMax," premières distance(s) de cook >= seuil\n") } # fin si tindDcook <- tind[flt,] # on trie idx <- order(abs(tindDcook[,10]),decreasing=TRUE) nbLigAff <- min(nb,nbLigMax) print(head(round(tindDcook[idx,],3),n=nbLigAff)) } else { cat("aucune distance de cook >= seuil = ",seu,"\n") } # fin si cat(" autres seuils possibles : souhaitable f(1,n-1,0.1) = ",round(qf(p=0.1,df1=1,df2=n-1),3)) cat(" ; précoccupant f(1,n-1,0.5) = ",round(qf(p=0.5,df1=1,df2=n-1),3)," Cook (1977) \n") cat("\n") # point(s) remarquable(s) vus par influence.measures mati <- influence.measures(ml)$infmat matl <- apply(FUN=as.numeric,X=influence.measures(ml)$is.inf,MARGIN=2) flt <- apply(FUN=sum,X=matl,MARGIN=1)>0 nb <- sum(flt) if (nb>0) { cat(nb," point(s) remarquable(s) vus par influence.measures (sans tri)\n") if(nb>nbLigMax) { cat(" on n'affiche que les ",nbLigMax," premiers points remarquables (sans tri)\n") } # fin si tindTinf <- tind[flt,] nbLigAff <- min(nb,nbLigMax) print(head(round(tindTinf[,],3),n=nbLigAff)) } else { cat("aucun point remarquable vu par influence.measures\n") } # fin si # pour debug : cat("\nsuite...\n") ; browser() # tracés éventuels avec stockage PNG alternatif if (graphiques) { # tracé 1 : points et droite de régression co <- coefficients(ml) a <- sprintf("%0.3f",co[2]) bf <- sprintf("%0.3f",co[1]) b <- co[1] sgn <- "+" if (b<0) { sgn <- "-" b <- abs(b) } # fin si corr <- paste(" (r=",sprintf("%0.3f",cor(xi,yi)),")",sep="") formule <- paste(" y = ",a," * x ",sgn,bf,sep="") if (basegr!="") { numgr <- numgr + 1 nomgr <- paste(basegr,numgr,".png",sep="") gr(nomgr) } # fin si plot(yi~xi,main=paste(titre,formule,corr,sep=""),cex=0.5) abline(ml) if (basegr!="") { dev.off() cat("\n vous pouvez utiliser ",nomgr,"\n") } # fin si # tracé 2 : on ajoute les intervalles de confiance grillex <- data.frame(sort(xi)) dimnames(grillex)[[2]] <- "xi" icConf <- predict(ml,new=grillex,interval="confidence",level=0.95) icPred <- predict(ml,new=grillex,interval="prediction",level=0.95) if (basegr!="") { numgr <- numgr + 1 nomgr <- paste(basegr,numgr,".png",sep="") gr(nomgr) } # fin si plot(yi~xi,cex=0.5,pch=20,main=titre) matlines(grillex,cbind(icConf,icPred[,-1]),lty=c(1,2,2,3,3),col=c("blue","red","red","green","green"),lw=2) legend("topleft",lty=1:3,c("reg","pred","conf"),col=c("blue","red","green"),lw=2) decal <- 3*(max(yi)-min(yi))/100 # formule empirique text(x=xi,y=yi+decal,labels=(1:n)) if (basegr!="") { dev.off() cat("\n vous pouvez utiliser ",nomgr,"\n") } # fin si # analyse des résidus, test de normalité if (basegr!="") { numgr <- numgr + 1 nomgr <- paste(basegr,numgr,".png",sep="") gr(nomgr) } # fin si decritQT("Résidus",ei," ",TRUE) if (length(xi)<3000) { cat("Test de normalité de Shapiro-Wilk\n") print(shapiro.test(ei)) } else { library(nortest) #cat("Test de normalité de Kolmogorov-Smirnov\n") #print(ks.test(ei,"pnorm")) cat("Test de normalité de Lilliefors\n") print(lillie.test(ei)) } # fin si par(mfrow=c(1,1)) if (basegr!="") { dev.off() cat("\n vous pouvez utiliser ",nomgr,"\n") } # fin si # puis les 6 tracés d'analyse des résidus for (i in (1:6)) { if (basegr!="") { numgr <- numgr + 1 nomgr <- paste(basegr,numgr,".png",sep="") gr(nomgr) } # fin si plot(ml,which=i,main=titre) if (basegr!="") { dev.off() cat("\n vous pouvez utiliser ",nomgr,"\n") } # fin si } # fin pour i # tracé des résidus studentisés et limites à -2, 2 if (basegr!="") { numgr <- numgr + 1 nomgr <- paste(basegr,numgr,".png",sep="") gr(nomgr) } # fin si plot(rst,pch=15,cex=0.5,ylab="Résidus studentisés",main=titre) abline(h=c(-2,0,2),col=c("red","blue","red"),lty=c(2,1,2),lw=2) decal <- 3*(max(rst)-min(rst))/100 # formule empirique text(x=(1:n),y=rst+decal,labels=(1:n)) if (basegr!="") { dev.off() cat("\n vous pouvez utiliser ",nomgr,"\n") } # fin si # on remet le mode ask à son ancienne valeur if (interactif) { par(ask=sovAsk) } # fin si } # fin si library(car) library(lmtest) cats("Test de l'homoscédasticité des résidus") # xiyi <- as.data.frame(cbind(xi,yi)) # ncvTest(lm(yi~xi,data=xiyi)) ne fonctionne pas ? print(bptest(lm(yi~xi))) # on renvoie le modèle, les coefficients et le tableau des indicateurs return(list(modele=ml,coefs=vcoef,indicateurs=tind)) } # fin de fonction analyseRegression ######################################################################### linmodelstats <- function(m) { ######################################################################### yi <- m$model[[1]] xi <- m$model[[2]] resi <- m$residuals lsf <- lsfit(x=xi,y=yi) lsd <- ls.diag(lsf) lev <- hatvalues(m) # leviers rsu <- rstandard(m) # résidu studentisé rst <- rstudent(m) # rstudent dfi <- lsd$dfits # dfits #dfb <- dfbetas(ml) coo <- cooks.distance(m) s1 <- summary(m)$r.squared s2 <- AIC(m) s3 <- BIC(m) s4 <- shapiro.test(m$residuals)$p.value s5 <- rmse(yi,m$fitted.values) s6 <- skewness(resi) s7 <- kurtosis(resi) s8 <- as.numeric(bptest(m)$p.value) s9 <- max(abs(coo)) s10 <- max(abs(lev)) s11 <- max(abs(dfi)) dfr <- data.frame( r2a=s1, AIC_crit=s2, BIC_crit=s3, residNorm=s4, RMSE=s5,Skewness=s6,Kurtosis=s7,BreuschPagan=s8, maxCook=s9,maxLevier=s10,maxDfits=s11 ) # fin de data.frame return(dfr) } # fin de fonction linmodelstats ######################################################################### checklm <- function(m) { ######################################################################### x <- m$model[[2]] # si, si ! y <- m$model[[1]] ml <- lm(y~x) library("MASS") ; mrlm <- rlm(y ~ x) library("quantreg") ; mlrq <- rq(y ~ x) library(robust) ; mrob1 <- lmRob(y~x,) require(robustbase) ; mrob2 <- lmrob(y~x,control = lmrob.control(max.it = 100)) dcoef <- data.frame( alm=coef(ml)[2], arlm=coef(mrlm)[2], arq=coef(mlrq)[2], aRob=coef(mrob1)[2], arob=coef(mrob2)[2], maxDiffa=NA, maxDiffaPct=NA, blm=coef(ml)[1], blrm=coef(mrlm)[1], brq=coef(mlrq)[1], brob=coef(mrob1)[1], bRob=coef(mrob2)[1], maxDiffb=NA, maxDiffbPct=NA ) # fin data.frame d1a <- abs(dcoef$alm[1]-dcoef$arlm[1]) d2a <- abs(dcoef$alm[1]-dcoef$arq[1]) d3a <- abs(dcoef$alm[1]-dcoef$arob1[1]) d4a <- abs(dcoef$alm[1]-dcoef$arob2[1]) diffa <- c(d1a,d2a,d3a,d4a) md <- which.max(diffa) dcoef$maxDiffa[1] <- diffa[md] dcoef$maxDiffaPct[1] <- 100*diffa[md]/dcoef$alm[1] d1b <- abs(dcoef$blm[1]-dcoef$brlm[1]) d2b <- abs(dcoef$blm[1]-dcoef$brq[1]) d3b <- abs(dcoef$blm[1]-dcoef$brob1[1]) d4b <- abs(dcoef$blm[1]-dcoef$brob2[1]) diffb <- c(d1b,d2b,d3b,d4b) md <- which.max(diffb) dcoef$maxDiffb[1] <- diffb[md] dcoef$maxDiffbPct[1] <- 100*diffb[md]/dcoef$blm[1] return(dcoef) } # fin de fonction checklm ################################################################# traceCor <- function(maintit,nomvarx,varx,unitx="",nomvary,vary,unity="") { ################################################################# if (missing(maintit)) { cat(" syntaxe : traceCor(maintit,nomvarx,varx,unitx,nomvary,vary,unity) \n") return(c()) } # fin de si rl <- lm(vary ~ varx) rho <- sprintf("%5.2f",cor(varx,vary)) co <- round(rl$coefficients,2) maintit2 <- paste(maintit,", r=",rho,", y=",co[2],"*x+",co[1],sep="") labx <- nomvarx if (unitx!="") { labx <- paste(labx," (",nomvarx,")",sep="") } laby <- nomvary if (unity!="") { laby <- paste(laby," (",nomvary,")",sep="") } plot(vary ~ varx,main=maintit2,col="blue",pch=21,bg="blue",xlab=labx,ylab=laby) abline(rl,col="red") } # fin de fonction traceCor ################################################################# boxplotQT <- function(titreQT, vecteurQT,ylims=0,moyenne=TRUE,lng="FR",unitQT="?",...) { ################################################################# # # un "boxplot" amélioré pour les QT # avec la moyenne en rouge if ((unitQT=="?")|(unitQT=="")) { leTitreQT <- titreQT } else { leTitreQT <- paste(titreQT," (",unitQT,")",sep="") } # finsi if (length(ylims)==1) { boxplot(vecteurQT,main=leTitreQT,col="yellow",pch=21,bg="red",...) } else { boxplot(vecteurQT,main=leTitreQT,col="yellow",pch=21,bg="red",ylim=ylims,...) } ; # fin de si if (moyenne) { abline(c(mean(vecteurQT,na.rm=TRUE),0),col="red",pch=21,lw=2) if (lng=="FR") { legend(x="topright",c("moyenne","médiane"),col=c("red","black"),lty=c(1,1),bty="n") } else { legend(x="topright",c("mean","median"),col=c("red","black"),lty=c(1,1),bty="n") } # fin si } ; # fin de si } ; # fin de fonction boxplotQT ################################################################# beanplotQT <- function(titreQT, vecteurQT,ylims=0,moyenne=TRUE,msg="oui",lng="FR",...) { ################################################################# # # un "beanplot" amélioré pour les QT # avec la moyenne en rouge library(beanplot) if (length(ylims)==1) { beanplot(vecteurQT,main=titreQT,col = c("#CAB2D6", "#33A02C", "#B2DF8A"), border = "#CAB2D6",...) } else { beanplot(vecteurQT,main=titreQT,col = c("#CAB2D6", "#33A02C", "#B2DF8A"), border = "#CAB2D6",ylim=ylims,...) } ; # fin de si if (moyenne) { abline(c(mean(vecteurQT),0),col="red",pch=21,lw=2) } } ; # fin de fonction beanplotQT ################################################################# violinplotQT <- function(titreQT, vecteurQT,ylims=0,moyenne=TRUE,msg="oui",lng="FR",...) { ################################################################# # # un "violinplot" amélioré pour les QT # avec la moyenne en rouge library(vioplot) if (length(ylims)==1) { vioplot(x=vecteurQT,col = "lightgreen",...) title(main=titreQT) } else { vioplot(x=vecteurQT,col = "lightgreen",ylim=ylims,...) title(main=titreQT) } ; # fin de si if (moyenne) { abline(c(mean(vecteurQT),0),col="red",pch=21,lw=2) } } ; # fin de fonction beanplotQT ################################################################# decritQT <- function(titreQT,nomVar,unite=" ",graphique=FALSE,fichier_image="",msg="oui",lng="FR",vmaxhist="",maxdec=4,rug=TRUE,lstem=100) { ################################################################# if (missing(titreQT)) { cat(" syntaxe : decritQT(titreQT,nomVar [ ,unite=\"?\",graphique=FALSE,fichier_image=\"\" ] ) \n") cat(" exemples d'utilisation : \n") cat(" decritQT(\"AGE dans ELF\",ag,\"ans\")\n") cat(" decritQT(\"POIDS dans Ronfle\",poi,\"kg\",graphique=TRUE,fichier_image=\"RON_poi.png\")\n") } else { cat("\n") if (lng=="FR") { cat("DESCRIPTION STATISTIQUE DE LA VARIABLE ",titreQT,"\n") ; } else { cat("STATISTICAL DESCRIPTION OF THE VARIABLE ",titreQT,"\n") ; } # fin si mdsc <- matrix(nrow=11,ncol=2) colnames(mdsc) <- rep(" ",2) ; if (lng=="FR") { rownames(mdsc) <- c(" Taille "," Moyenne"," Ecart-type"," Coef. de variation", " 1er Quartile", " Mediane "," 3eme Quartile"," iqr absolu", " iqr relatif", " Minimum"," Maximum") } else { rownames(mdsc) <- c(" Size "," Mean"," Standard deviation"," Coef. of variation", " 1st Quartile", " Median "," 3d Quartile"," absolute iqr", " relative iqr", " Minimum"," Maximum") } # fin si nomVar <- nomVar[ !is.na(nomVar) ] taille <- length(nomVar) ; moyenne <- sum(nomVar)/taille ; ecartype <- sd(nomVar) cdv <- round( cv(nomVar) ) #mdsc[1,1] <- formatC(taille,format="d",width=4) ; #mdsc[1,1] <- sprintf("%9.0f",taille) mdsc[1,1] <- sprintf("%5.0f ",taille) if (lng=="FR") { mdsc[1,2] <- " individus"; } else { mdsc[1,2] <- " individuals"; } # fin si outformat <- paste("%9.",maxdec,"f",sep="") mdsc[2,1] <- sprintf(outformat,moyenne) mdsc[2,2] <- unite ; mdsc[3,1] <- formatC(ecartype,format="f",width=9,dig=4) ; mdsc[3,2] <- unite ; mdsc[4,1] <- sprintf("%5.0f ",cdv) mdsc[4,2] <- "% " ; #mdsc[5,1] <- formatC(quantile(nomVar,0.25),9,dig=4) ; mdsc[5,1] <- sprintf(outformat,quantile(nomVar,0.25)) mdsc[5,2] <- unite; mdsc[6,1] <- formatC(quantile(nomVar,0.50),9,dig=4) ; # ou median(nomVar) ; mdsc[6,1] <- sprintf(outformat,quantile(nomVar,0.50)) mdsc[6,2] <- unite; mdsc[7,1] <- formatC(quantile(nomVar,0.75),9,dig=4) ; mdsc[7,1] <- sprintf(outformat,quantile(nomVar,0.75)) mdsc[7,2] <- unite; mdsc[8,1] <- formatC(quantile(nomVar,0.75)-quantile(nomVar,0.25),9,dig=4) ; mdsc[8,1] <- sprintf(outformat,quantile(nomVar,0.75)-quantile(nomVar,0.25)) mdsc[8,2] <- unite; mdsc[9,1] <- sprintf(outformat,round(100*(quantile(nomVar,0.75)-quantile(nomVar,0.25))/(quantile(nomVar,0.50)))) mdsc[9,2] <- "% "; mdsc[10,1] <- sprintf("%9.3f",min(nomVar)) ; #mdsc[10,1] <- sprintf("%5.0f ",min(nomVar)) ; mdsc[10,2] <- unite; mdsc[11,1] <- sprintf("%9.3f",max(nomVar)) ; #mdsc[11,1] <- sprintf("%5.0f ",max(nomVar)) ; mdsc[11,2] <- unite; print(mdsc,quote=FALSE,right=TRUE) ; if (graphique) { if (vmaxhist=="") { plotQTdet(titreQT,nomVar,unite,tigef=TRUE,grfile=fichier_image,msg=msg,lng=lng,rug=rug,lngstem=lstem) } else { plotQTdet(titreQT,nomVar,unite,tigef=TRUE,grfile=fichier_image,msg=msg,lng=lng,maxhist=vmaxhist,rug=rug,lngstem=lstem) } } # fin si sur graphique cat("\n") if (interactive()) { scr(1) } # else { cat("non interactif\n") } } # fin si sur missing(titreQT) } ; # fin de fonction decritQT ################################################################# tdn <- function(titreQT,nomVar,unite="?",graphique=FALSE,fichier_image="") { ################################################################# # on retire les NA y <- nomVar nbna <- sum(is.na(y)) y <- na.omit(y) # tests de normalité cat("\nTESTS DE NORMALITE POUR LA VARIABLE y =",titreQT,"\n\n") cat(" pour ",length(y)," valeurs (",nbna," valeurs NA)\n\n",sep="") # on teste respectivement y, log(y+1), sqrt(y), 1/y, y*y # par les test de ks et de shapiro nbm <- 6 mdv <- matrix(nrow=length(y),ncol=nbm) mdv[,1] <- y mdv[,2] <- sqrt(y) mdv[,3] <- 1/y mdv[,4] <- y*y mdv[,5] <- log(y+1) mdv[,6] <- log(log(y+1)) noms <- vector(length=nbm) noms[1] <- "y" noms[2] <- "sqrt(y)" noms[3] <- "1/y" noms[4] <- "y^2" noms[5] <- "ln(y+1)" noms[6] <- "ln(ln(y+1))" mtn <- matrix(nrow=2*nbm,ncol=3) colnames(mtn) <- c("Variable","Test","p-value") row.names(mtn) <- rep("",dim(mtn)[1]) for (idm in (1:nbm)) { v <- mdv[,idm] jdm <- 2*idm-1 mtn[jdm,1] <- noms[idm] mtn[jdm+1,1] <- mtn[jdm,1] mtn[jdm,2] <- "Kolmogorov-Smirnov" mtn[jdm,3] <- sprintf("%16.10f",ks.test(v,pnorm,mean=mean(v),sd=sd(v))$p.value) mtn[jdm+1,2] <- "Shapiro" mtn[jdm+1,3] <- sprintf("%16.10f",shapiro.test(v)$p.value) } # fin pour idm # print(mtn,quote=FALSE,right=TRUE) ; idx <- rev(order(mtn[,3])) mtn <- mtn[idx,] print(mtn,quote=FALSE,right=TRUE) ; if (graphique) { if (!fichier_image=="") { png(fichier_image,width=1024,height=768) ; graphique = TRUE } par(mfrow=c(3,2)) for (idm in (1:nbm)) { vecteurQT <- mdv[,idm] nom <- sub("y",titreQT,noms[idm]) titreHDC <- paste("Histogramme des classes pour ",nom,sep="") hist(vecteurQT,col="light blue",probability = TRUE,main=titreHDC ,xlab="",ylab="") vnorm <- function(x) { dnorm(x,mean=mean(vecteurQT),sd=sd(vecteurQT)) } curve(vnorm,add=TRUE,col="red",lwd=2) } # fin pour idm par(mfrow=c(1,1)) if (!fichier_image=="") { dev.off() } } # fin si sur graphique } ; # fin de fonction tdn ################################################################# rch_VE <- function(titreQT,nomVar,unite="?") { ################################################################# # recherche de valeurs extremes cat("RECHERCHE DE VALEURS EXTREMES POUR LA VARIABLE y =",titreQT,"\n\n") lng <- length(nomVar) moy <- mean(nomVar) ect <- sd(nomVar) cdv <- 100*ect/moy vt <- sort(nomVar) cat(" Moyenne :",moy,"unite ; écart-type : ",ect," ; cdv : ",sprintf("%5.1f",cdv),"%\n\n") ; cat(" Les 5 premières valeurs arrondies : ",round(vt[1:5]),"\n") ; cat(" Les 5 dernières valeurs arrondies : ",round(rev(rev(vt)[1:5])),"\n") ; cat("\n") cat(" Les 10 premières valeurs arrondies : ",round(vt[1:10]),"\n") ; cat(" Les 10 dernières valeurs arrondies : ",round(rev(rev(vt)[1:10])),"\n") ; cat("\n") for (elg in c(2,3,5,7)) { vinf <- moy-elg*ect vsup <- moy+elg*ect nbinf <- sum(nomVar<vinf) nbsup <- sum(nomVar>vsup) if (nbinf+nbsup==0) { cat(" Il n'y a aucune valeur à l'extérieur de l'intervalle [ m -",elg,"s , m + ",elg,"s ].\n") ; } else { if (nbinf==0) { cat(" Il y n'a aucune valeur inférieure à m -",elg,".\n") ; } else { cat(" Il y a",nbinf," valeurs, soit ",sprintf("%4.1f",100*nbinf/lng),"% inférieures à m -",elg,"s à savoir : ") ; cat(nomVar[nomVar<vinf]," \n") ; } # fin si nbinf if (nbsup==0) { cat(" Il y n'a aucune valeur supérieure à m +",elg,".\n") ; } else { cat(" Il y a",nbsup," valeurs, soit ",sprintf("%4.1f",100*nbsup/lng),"% supérieures à m +",elg,"s à savoir : ") ; cat(nomVar[nomVar>vsup]," \n") ; } # fin si nbsup } # fin si nbinf+nbsup==0 cat("\n") } # fin pour cat("\n") m1 <- mean(nomVar,trim=0.1) m2 <- mean(nomVar,trim=0.2) cat(" Moyenne tronquée à 10 % : ",m1,"\n") ; cat(" Moyenne tronquée à 20 % : ",m2,"\n\n") ; v1 <- vt[vt>min(vt)] v2 <- vt[vt<max(vt)] m3 <- mean(v1) m4 <- mean(v2) e3 <- sd(v1) e4 <- sd(v2) c3 <- 100*e3/m3 c4 <- 100*e4/m4 f3 <- sprintf("%5.1f",c3) f4 <- sprintf("%5.1f",c4) cat(" Valeurs strictement supérieures au minimum : \n") ; cat(" moyenne : ",m3,"\n") ; cat(" écart-type : ",e3,"\n") cat(" cdv : ",f3,"%\n") ; cat(" Valeurs strictement inférieures au au maximum : \n") ; cat(" moyenne : ",m4,"\n") ; cat(" écart-type : ",e4,"\n") cat(" cdv : ",f4,"%\n") ; cat("\n") } ; # fin de fonction rch_VE ################################################################# dtQT <- function(titreQT,nomVar,unite="?",graphique=FALSE,base_fichier_image="",ficimg2="") { ################################################################# # decritQT et tests de normalité # deux appels possibles pour les fichiers images : # une base ou les deux noms précis (pour appel par serveur web) if (!graphique) { decritQT(titreQT,nomVar,unite,FALSE) tdn(titreQT,nomVar,unite,FALSE) } else { if (base_fichier_image=="") { fichier_image1 <- "" fichier_image2 <- "" } else { if (ficimg2=="") { fichier_image1 <- paste(base_fichier_image,"1.png",sep="") fichier_image2 <- paste(base_fichier_image,"2.png",sep="") } else { fichier_image1 <- base_fichier_image fichier_image2 <- ficimg2 } # fin si sur ficimg2 } # fin si sur base_fichier_image decritQT(titreQT,nomVar,unite,TRUE,fichier_image1) tdn(titreQT,nomVar,unite,TRUE,fichier_image2) } # fin si sur graphique # dans tous les cas de figure, # recherche de valeurs extremes cat("\n") rch_VE(titreQT,nomVar,unite) } ; # fin de fonction dtQT ################################################################# allCalcQT <- function(titreQT,nomVar,unite=" ",maxDec=3) { ################################################################# if (missing(titreQT)) { cat(" allCalcQT : calculs usuels pour une seule QT\n") ; cat(" syntaxe : allCalcQT(titre,nomVar,unité) \n") cat(" exemple : allCalcQT(\"AGE dans ELF\",ag,\"ans\") \n") return() ; } ; # fin de si mdsc <- vector(length=11) taille <- length(nomVar) ; moyenne <- sum(nomVar)/taille ; ecartype <- ect(nomVar) cdv <- round( cv(nomVar) ) # formats communs larg <- 9 fmtD <- paste("%6d") fmtF <- paste("%",larg,".",maxDec,"f" ,sep="") mdsc[1] <- sprintf(fmtD,taille) ; mdsc[2] <- sprintf(fmtF,moyenne) ; mdsc[3] <- unite ; mdsc[4] <- sprintf(fmtF,ecartype) ; mdsc[5] <- cdv mdsc[6] <- sprintf(fmtF,quantile(nomVar,0.25)) ; mdsc[7] <- sprintf(fmtF,quantile(nomVar,0.50)) ; mdsc[8] <- sprintf(fmtF,quantile(nomVar,0.75)) ; mdsc[9] <- sprintf(fmtF,quantile(nomVar,0.75)-quantile(nomVar,0.25)) ; mdsc[10] <- sprintf(fmtF,min(nomVar)) ; mdsc[11] <- sprintf(fmtF,max(nomVar)) ; return(mdsc) ; } ; # fin de fonction allCalcQT ################################################################# decritQTparFacteur <- function(titreQT,nomVarQT,unite=" ",titreQL,nomVarQL,labels,graphique=FALSE,fichier_image="",lng="FR",beanp=TRUE,cnt=1,coul=c("blue","red"),back=FALSE) { ################################################################# if (missing(titreQT)) { cat(" syntaxe : decritQTparFacteur(titreQT,nomVar,unite=\"?\",titreQL,nomVarQL,labels, [ graphique=FALSE,fichier_image=\"\" ] ) \n") cat(" exemples d'utilisation : \n") cat(" decritQTparFacteur(\"AGE dans ELF\",ag,\"ans\",\"SEXE\",sex,\"homme femme\")\n") cat(" decritQTparFacteur(\"POIDS dans Ronfle\",poi,\"kg\",,\"SEXE\",sexe,\"homme femme\"graphique=TRUE,fichier_image=\"RON_poi.png\")\n") } else { nas <- is.na(nomVarQT) nbnas <- sum(nas) if (nbnas>0) { cat("\n ",nbnas," valeurs manquantes supprimées sur ",length(nomVarQT),"\n") nomVarQT <- nomVarQT[!nas] nomVarQL <- nomVarQL[!nas] } ; # fin si if (unite==" ") { unite_ <- " " } else { unite_ <- paste(",unit=",unite,sep="") } # fin si cat("\n") if (lng=="FR") { cat("VARIABLE QT ",titreQT,unite_,"\n") ; cat("VARIABLE QL ",titreQL," labels : ",labels,"\n") ; } else { cat("QT VARIABLE: ",titreQT,unite_,"\n",sep="") ; cat("QL VARIABLE: ",titreQL,", labels =",labels,"\n") ; } ; # fin de si cat("\n") nbl <- length(nomVarQT) tdata <- matrix(nrow=nbl,ncol=2) tdata[,1] <- nomVarQT tdata[,2] <- nomVarQL if (length(labels)==1) { labels <- chaineEnListe( labels ) } ## print(labels) vglob <- list() vglob[[1]] <- tdata[,1] valQL <- sort(unique(nomVarQL)) nbm <- length(valQL) for (idm in (1:nbm)) { vglob[[1+idm]] <- nomVarQT[nomVarQL==valQL[idm]] } # fin pour idm vres <- matrix(nrow=1+nbm,ncol=11) vres[1,] <- allCalcQT("Global",vglob[[1]],unite) for (idm in (1:nbm)) { vres[1+idm,] <- allCalcQT(labels[idm],vglob[[1+idm]],unite) } # fin pour idm row.names(vres) <- c("Global",labels) if (lng=="FR") { colnames(vres) <- chaineEnListe("N Moy Unite Ect Cdv Q1 Med Q3 EIQ Min Max") } else { colnames(vres) <- chaineEnListe("N Mean Unit Std Cv Q1 Med Q3 IQR Min Max") } ; # fin de si print(vres,quote=FALSE,right=TRUE) ; if (!fichier_image=="") { gr(fichier_image) ; graphique = TRUE } if (graphique) { titre <- paste(titreQT," vs ",titreQL) if (nbm>2) { nbgr <- 1 } else { nbgr <- 2 } # fin si if (beanp) { nbgr <- nbgr + 1 } par(mfrow=c(1,nbgr)) couls <- rep("black",nbl) couls[nomVarQL==min(nomVarQL)] <- coul[1] couls[nomVarQL==max(nomVarQL)] <- coul[2] titrex <- paste(min(nomVarQL),"en bleu, ", max(nomVarQL)," en rouge ") titrex <- paste(labels[1],coul[1],";", labels[2],coul[2]) titrey <- "" ql <- as.factor(nomVarQL) levels(ql) <- labels bornesY <- c(min(nomVarQT)*0.9,max(nomVarQT)*1.1) if (nbm<=2) { plot(1:nbl,nomVarQT,col=couls,pch=21,bg=coul,main=titre,xlab=titrex,ylab=titrey,ylim=bornesY) } ql2 <- ql ql3 <- ql cntql <- table(ql) for (idc in 1:length(cntql)) { levels(ql2)[idc] <- paste(levels(ql)[idc]," (",cntql[idc],")",sep="") levels(ql3)[idc] <- paste(" \n",levels(ql)[idc],"\n",cntql[idc],sep="") } # fin pour idc if (cnt==1) { qlt <- ql2 } else { qlt <- ql3 } # fin si boxplot(nomVarQT~qlt,main=titre,col="yellow",pch=21,bg="red",notch=FALSE,ylim=bornesY) if (beanp) { library(beanplot) beanplot(nomVarQT~qlt,main=titre,col = c("#CAB2D6", "#33A02C", "#B2DF8A"), border = "#CAB2D6",ylim=bornesY,log="") } # fin si par(mfrow=c(1,1)) } # fin si if (!fichier_image=="") { cat("\n") if (lng=="FR") { cat(" vous pouvez utiliser ",fichier_image,"\n") } ; # fin de si dev.off() } ; # fin de si #cat("Résultats de l'anova : \n") cat("\n") ql <- as.factor(nomVarQL) an <- anova(lm(nomVarQT~ql)) print(an) if (back) { if (length(table(ql))==2) { library(aplpack) decoupe <- split(nomVarQT,ql) stem(decoupe[[1]]) stem(decoupe[[2]]) stem.leaf.backback(decoupe[[1]],decoupe[[2]],back.to.back=TRUE) stem.leaf.backback(decoupe[[1]],decoupe[[2]],back.to.back=TRUE,trim.outliers=FALSE) } # fin si } # fin si showDetails <- 1 if (showDetails==1) { pval <- an$"Pr(>F)"[1] cat("ANOVA : there is") if (pval<0.05) { cat(" a") } else { cat(" no") } # fin si cat(" significant difference at the level 0.05 for ",titreQT," ",titreQL,"\n") } # fin si # analyse non paramétrique if (length(table(ql))==2) { wit <- wilcox.test(nomVarQT~ql) print(wit) pval <- wit$p.value nomTest <- "WILCOXON" } else { kwt <- kruskal.test(nomVarQT~ql) print(kwt) pval <- kwt$p.value nomTest <- "KRUSKAL-WALLIS" } # finsi if (showDetails==1) { cat(nomTest,": there is") if (pval<0.05) { cat(" a") } else { cat(" no") } # fin si cat(" significant difference at the level 0.05 for ",titreQT," ",titreQL,"\n") } # fin si return(an$"Pr(>F)"[1]) } # fin si } ; # fin de fonction decritQTparFacteur ################################################################# decritQTparFacteurTexte <- function(titreQT,nomVarQT,unite="?",titreQL,nomVarQL,lstMod,graphique=FALSE,fichier_image="",haricot=0) { ################################################################# if (missing(titreQT)) { cat(" syntaxe : decritQTparFacteurTexte(titreQT,nomVar,unite=\"?\",titreQL,nomVarQL,labels, [ graphique=FALSE,fichier_image=\"\" ] ) \n") cat(" exemples d'utilisation : \n") cat(" decritQTparFacteurTexte(\"AGE dans CETOP\",ag,\"ans\",\"SEXE\",sexT,\"hom fam\")\n") cat(" decritQTparFacteurTexte(\"POIDS dans SANTE\",poi,\"kg\",,\"SEXE\",sexeT,\"homme femme\"graphique=TRUE,fichier_image=\"RON_poi.png\")\n") } else { cat("VARIABLE QT ",titreQT," unité : ",unite,"\n") ; cat("VARIABLE QL ",titreQL," labels : ",lstMod,"\n") ; cat("\n") nbl <- length(nomVarQT) if (length(lstMod)==1) { lstMod <- chaineEnListe( lstMod ) } vglob <- list() vglob[[1]] <- nomVarQT nbm <- length(lstMod) for (idm in (1:nbm)) { vglob[[1+idm]] <- nomVarQT[nomVarQL==lstMod[idm]] } # fin pour idm vres <- matrix(nrow=1+nbm,ncol=11) vres[1,] <- allCalcQT("Global",vglob[[1]],unite) for (idm in (1:nbm)) { vres[1+idm,] <- allCalcQT(lstMod[idm],vglob[[1+idm]],unite) } # fin pour idm row.names(vres) <- c("Global",lstMod) colnames(vres) <- chaineEnListe("N Moy Unite Ect Cdv Q1 Med Q3 EIQ Min Max") print(vres,quote=FALSE,right=TRUE) ; if (graphique) { if (!fichier_image=="") { png(fichier_image,width=1024,height=768) } titre <- paste(titreQT," vs ",titreQL) ## par(mfrow=c(1,1)) if (haricot==0) { boxplot(nomVarQT~nomVarQL,main=titre,col="yellow",pch=21,bg="red",notch=TRUE) } else { library(beanplot) beanplot(nomVarQT~nomVarQL,main=titre,col = c("#CAB2D6", "#33A02C", "#B2DF8A"), border = "#CAB2D6") } ; # fin si if (!fichier_image=="") { dev.off() } } # fin si cat("\n") ql <- as.factor(nomVarQL) an <- anova(lm(nomVarQT~ql)) print(an) showDetails <- 1 if (showDetails==1) { pval <- an$"Pr(>F)"[1] cat("ANOVA: there is") if (pval<0.05) { cat(" a") } else { cat(" no") } # fin si cat(" significant difference at the level 0.05 for ",titreQT," ",titreQL,"\n") } # fin si # analyse non paramétrique kwt <- kruskal.test(nomVarQT~ql) print(kwt) if (showDetails==1) { pval <- kwt$p.value cat("KRUSKAL-WALLIS : there is") if (pval<0.05) { cat(" a") } else { cat(" no") } # fin si cat(" significant difference at the level 0.05 for ",titreQT," ",titreQL,"\n") } # fin si return(an$"Pr(>F)"[1]) } # fin si } ; # fin de fonction decritQTparFacteurTexte ################################################################# compare2QT <- function(titreGen,modaQt1,varQt1,modaQt2,varQt2,unite,graph=FALSE,fichier_image="") { ################################################################# if (missing(titreGen)) { cat(" syntaxe : compare2QT \n\n") cat(" exemple : compare2QT(\"age vs sexe\",\"homme\",ah,\"femme\",af,\"ans\",TRUE) \n\n") } else { n1 <- length(varQt1) n2 <- length(varQt2) #vaql <- c( rep(modaQt1,n1), rep(modaQt2,n2) ) vaql <- c( rep(1,n1), rep(2,n2) ) moda <- c(modaQt1,modaQt2) vaqt <- c(varQt1,varQt2) print( shapiro.test(varQt1) ) print( shapiro.test(varQt2) ) print( var.test(varQt1,varQt2) ) print( t.test(varQt1,varQt2) ) print( wilcox.test(varQt1,varQt2) ) #decritQTparFacteurTexte(titreGen,vaqt,unite,"Groupes",vaql,moda,graph,fichier_image) decritQTparFacteur(titreGen,vaqt,unite,"Groupes",vaql,moda,graph,fichier_image) } # fin si } ; # fin de fonction compare2QT ################################################################# compare2QTappariees <- function(titreGen,modaQt1,varQt1,modaQt2,varQt2,unite,graph=FALSE,fichier_image="") { ################################################################# if (missing(titreGen)) { cat(" syntaxe : compare2QT \n\n") } else { n1 <- length(varQt1) n2 <- length(varQt2) vaql <- c( rep(modaQt1,n1), rep(modaQt2,n2) ) moda <- c(modaQt1,modaQt2) vaqt <- c(varQt1,varQt2) print( shapiro.test(varQt1) ) print( shapiro.test(varQt2) ) print( var.test(varQt1,varQt2) ) print( t.test(varQt1,varQt2,paired=TRUE) ) print( wilcox.test(varQt1,varQt2,paired=TRUE) ) decritQTparFacteurTexte(titreGen,vaqt,unite,"Groupes",vaql,moda,graph,fichier_image) } # fin si } ; # fin de fonction compare2QTappariees ################################################################# ect <- function(vecteurQt) { ################################################################# # le "vrai" écart-type, issu de la "vraie" variance, mathématique et "biaisée" return( sqrt( vvar(vecteurQt) ) ) } ; # fin de fonction ect ################################################################# cv <- function(vecteurQt) { ################################################################# # le coefficient de variation basé sur ect mdv <- mean(vecteurQt,na.rm=TRUE) if (abs(mdv)<10**(-9)) { fcv <- (-1) } else { fcv <- 100*ect(vecteurQt) / mdv } # fin de si return( fcv ) } ; # fin de fonction cv ###################################################################### analyseMedianes <- function(df,ldv,nomVarGroup,nomGrp,eps=0.05,print=TRUE,caract=FALSE,varsToKeep) { ###################################################################### # on passe en revue chaque variable de la liste numérique ldv (données dans df) # les groupes sont indiqués numériquement dans nomVarGroup # le nom de groupe associé au numéro de groupe est dans nomGrp # pour chaque variable, on teste si la médiane pour un groupe est # non significativement ("NS") différente du reste des données, si elle est # significativement inférieure ("<") ou supérieure (">") # exemple d'utilisation : # --------------------- # # lesGroupes <- c("Pool1","Pool2","Pool3","WHy","Class8","IDP","FS") # # toler <- 0.01 # cag <- c(2:15,56:86) -1 # colonnes à garder # mm <- analyseMedianes(art3,02:86,"group",lesGroupes,toler,print=FALSE,caract=TRUE,cag) nbg <- length(nomGrp) # nombre de groupes nbgp <- 1 + nbg # la dernière ligne est la médiane globale nbv <- length(ldv) # nombre de variables da <- df[,ldv] # extraction des données grps <- df[,nomVarGroup] # numéros de groupes # on calcule le tableau des médianes par groupe # on passe en revue chaque variable # et pour chaque variable on passe en revue chaque groupe matMed <- matrix(nrow=nbgp,ncol=nbv) row.names(matMed) <- c(nomGrp,"global") colnames(matMed) <- colnames(df)[ldv] for (idv in (1:nbv)) { for (idg in (1:nbg)) { flt <- df[,nomVarGroup]==idg # filtre par numéro de groupe dase <- da[flt,idv] # data sélectionné laMed <- median(dase) # médiane correspondante matMed[idg,idv] <- laMed } # fin pour idv matMed[nbgp,idv] <- median(da[,idv]) } # fin pour idv mm1a <<- matMed # pour test # on prépare le tableau des résultats matResMed <- matrix(nrow=nbg,ncol=nbv) row.names(matResMed) <- nomGrp colnames(matResMed) <- colnames(df)[ldv] # on passe en revue chaque variable # on passe en revue chaque groupe for (idv in (1:nbv)) { for (idg in (1:nbg)) { flt <- df[,nomVarGroup]==idg dase <- da[flt,idv] dans <- da[(!flt),idv] kr <- kruskal.test(x=list(dase,dans)) pval <- kr$p.value if (pval<eps) { matResMed[idg,idv] <- "NS" } else { if (median(dase)<median(dans)) { matResMed[idg,idv] <- "<" } else { matResMed[idg,idv] <- ">" } # fin si } # fin si } # fin pour idg } # fin pour idv # affichage éventuel if (print) { cat("relative tolerance: ",eps*100," %\n") print(matMed,quote=FALSE,right=FALSE) print(matResMed,quote=FALSE,right=FALSE) } # fin si # caractérisation éventuelle groupe par groupe # sur un ensemble filtré de variables mm1b <<- matResMed # pour test if (caract) { matResMed2 <- matResMed[,varsToKeep] cats("Caractérisation des groupes") for (idg in (1:nbg)) { cats(paste("Groupe",idg,":",nomGrp[idg]),"-") vd <- which(!matResMed2[idg,]=="NS") # variable discriminante pour le groupe # est-ce le seul groupe discriminé ? vvd <- c() # variable vraiment discriminante for (idv in vd) { # mieux que for (idv in (1:length(vd)) cnt <- sum(!matResMed2[,idv]=="NS") if (cnt==1) { vvd <- c(vvd,idv) # variable vraiment discriminante } # fin si } # fin pour idv print(matResMed2[,vvd,drop=FALSE],quote=FALSE) } # fin pour idg } # fin si # on renvoie la matrice des médianes et celle des résultats en "NS", "<" et ">" return(list(matMed,matResMed)) } # fin de fonction analyseMedianes ################################################################# ################################################################# # # # Fonctions liées aux corrélations, linéires ou non # # # # # ################################################################# ################################################################# matCor <- function(dataMatrix,nomV="",meilcor=FALSE,method="pearson",maxcor=FALSE,mincor=FALSE) { ################################################################# # un simple synonyme pour mdc mdc(dataMatrix,nomV,meilcor,method,maxcor,mincor) } ; # fin de fonction matCor ################################################################# mdc <- function(dataMatrix,nomV="",meilcor=FALSE,method="pearson",maxcor=FALSE,mincor=FALSE,stopcor=0,print=TRUE) { ################################################################# # calcul de la matrice des coefficients de corrélation linéaire # # nomV est le nom des variables # exemple d'utilisation : # # mdc(lesQT,c("AGE","POIDS","TAILLE","ALCOOL")) # if (missing(dataMatrix)) { cat("mdc : Matrice Des Coefficients de corrélation \n") cat("syntaxe : mdc(dataMatrix,nomV=\"\",meilcor=FALSE,method=\"pearson\")\n") return() } # fin de si dm <- dim(dataMatrix) ; nl <- dm[1] nc <- dm[2] resMat <- matrix(nrow=nc,ncol=9) if (length(nomV)==1) { if (nomV=="") { nomV <- colnames(dataMatrix) } } # finsi corMat <- matrix(nrow=nc,ncol=nc) ; pvalue <- matrix(nrow=nc,ncol=nc) ; rownames(corMat) <- as.vector(nomV) colnames(corMat) <- nomV meiCor <- (-3) iEtj <- "-99" for (i in 1:nc) { vi <- dataMatrix[,i] for (j in 1:nc) { if (i<j) { f_cor <- "" } else { vj <- dataMatrix[,j] corij <- cor(vi,vj,use="pairwise.complete.obs",method=method) #cat(" i j corij meilCor ",i,j,corij,meiCor,"\n") if (!is.na(corij)) { if ((meiCor<corij) & (i!=j)) { meiCor <- corij iEtj <- c(i,j) } # fin de si sur meiC } # fin de si sur na de corij f_cor <- formatC(corij,"f",width=5,dig=3) } ; # fin de si sur i<j corMat[i,j] <- f_cor pvalue[i,j] <- cor.test(vi,vj,use="pairwise.complete.obs")$p.value #cat(" i j f_cor ",i,j,f_cor,"\n") } # fin pour j } # fin pour i if (print) { cat("\nMatrice des corrélations au sens de ",ucfirst(method),"pour ",nl," lignes et ",nc," colonnes\n\n") ; print(corMat,quote=FALSE,right=TRUE) ; } # fin si if (nc>1) { if (maxcor) { cat("\nMeilleure corrélation hors diagonale : ") cm <- cor(dataMatrix,method=method,use="pairwise.complete.obs") for (i in 1:nc) { cm[i,i] <- 0 } # fin pour i cormax <- max(abs(cm)) for (i in 2:nc) { for (j in 1:(i-1)) { if (abs(cm[i,j])==cormax) { f_cor <- sprintf("%8.3f",cm[i,j]) cat(f_cor," pour ") cat(colnames(cm)[i]," et ",colnames(cm)[j]) } ; # fin si } # fin pour i } # fin pour i if (!mincor) { cat("\n") } } ; # fin de si if (mincor) { cat("\nPlus faible coefficient de corrélation : ") cm <- cor(dataMatrix,method=method,use="pairwise.complete.obs") cormin <- min(abs(cm)) for (i in 2:nc) { for (j in 1:(i-1)) { if (abs(cm[i,j])==cormin) { f_cor <- sprintf("%8.3f",cm[i,j]) cat(f_cor," pour ") cat(colnames(cm)[i]," et ",colnames(cm)[j]) } ; # fin si } # fin pour i } # fin pour i cat("\n") } ; # fin de si if (method=="pearson") { if (meilcor) { # Meilleures corrélations xmeiCor <- iEtj[1] ymeiCor <- iEtj[2] nomX <- nomV[xmeiCor] nomY <- nomV[ymeiCor] lesX <- dataMatrix[,xmeiCor] lesY <- dataMatrix[,ymeiCor] #lesC <- lm( lesY ~ lesX,model=FALSE ) # à cause des arrondis, on recalcule les valeurs précises idX <- !is.na(lesX) idY <- !is.na(lesY) lesX <- lesX[ idX & idY ] lesY <- lesY[ idX & idY ] mX <- mean(lesX) eX <- sqrt( mean(lesX*lesX) - mX*mX) mY <- mean(lesY) eY <- sqrt( mean(lesY*lesY) - mY*mY) ro <- (mean(lesX*lesY) - mX*mY)/(eX*eY) vA <- ro*eY/eX vB <- mY - vA*mX wA <- ro*eX/eY wB <- mX - wA*mY if (vB<0) { sgn1 <- "" } else { sgn1 <- "+" } if (wB<0) { sgn2 <- "" } else { sgn2 <- "+" } pval <- formatC( cor.test(lesX,lesY,use="pairwise.complete.obs")$p.value, width=5,dig=3) cat("\nMeilleure corrélation ",meiCor," pour ",nomX," et ",nomY," p-value ",pval,"\n\n") ; fXY <- paste(nomY," = ",formatC(vA,"f",width=9,dig=3),"*",nomX," ",sgn1,formatC(vB,"f",width=9,dig=3)) ; fYX <- paste(nomX," = ",formatC(wA,"f",width=9,dig=3),"*",nomY," ",sgn2,formatC(wB,"f",width=9,dig=3)) ; cat("Formules ",fXY,"\n") ; cat(" et ",fYX,"\n") ; # tracé correspondant à la meilleure corrélation oX <- order(lesX) newX <- lesX[ oX] newY <- lesY[ oX] #par(lwd=2) #postscript("r.ps") ; #plot(newX,newY,"b",col="red",pch=21,bg="orange",fg="black",xlab=nomX,ylab=nomY) #title(paste(" Régression ",fXY," (rho=",meiCor,")")) #abline(c(vB,vA),col="blue") #dev.off() # affichage des corrélations par ordre décroissant # on en fait d'abord un vecteur de valeurs if (nc>2) { cat("\n Coefficients de corrélation par ordre décroissant \n\n") ; if (stopcor>0) { cat("(on se restreint aux corrélations supérieures à ",stopcor," en valeur absolue)\n\n",sep="") } # fin si tvec <- nc*(nc-1)/2 vecMdc <- matrix(nrow=tvec,ncol=4) ; # initialisation for (idc in 1:tvec) { vecMdc[idc,1] <- 0 vecMdc[idc,2] <- 0 vecMdc[idc,3] <- 0 } # fin pour idc # remplissage idc <- 0 for (i in 2:nc) { for (j in 1:(i-1)) { idc <- idc + 1 vcor <- corMat[i,j] # pour debug : cat(i,j,idc,vcor,"\n") ; vecMdc[idc,1] <- vcor vecMdc[idc,2] <- i vecMdc[idc,3] <- j vecMdc[idc,4] <- pvalue[i,j] } # fin pour j } # fin pour i # tri de vecMdc if (tvec>1) { for (idc in 1:(tvec-1)) { for (jdc in (idc+1):tvec) { vecMdc[idc,1] -> vi vecMdc[jdc,1] -> vj if (vi<vj) { vecMdc[idc,2] -> vi2 ; vecMdc[idc,3] -> vi3 ; vecMdc[idc,4] -> vi4 vecMdc[jdc,2] -> vj2 ; vecMdc[jdc,3] -> vj3 ; vecMdc[jdc,4] -> vj4 vecMdc[idc,1] <- vj ; vecMdc[idc,2] <- vj2 ; vecMdc[idc,3] <- vj3 ; vecMdc[idc,4] <- vj4 vecMdc[jdc,1] <- vi ; vecMdc[jdc,2] <- vi2 ; vecMdc[jdc,3] <- vi3 ; vecMdc[jdc,4] <- vi4 } # fin de si } # fin pour jdc } # fin pour idc } # fin de si # affichage nomC <- rownames(corMat) ; lngMax <- max(sapply(nomC,nchar)) for (i in 1:tvec) { f1 <- formatC(vecMdc[i,1],"f",width=9,dig=3) ; f2 <- formatC(vecMdc[i,2],"f",width=9,dig=3) ; f3 <- formatC(vecMdc[i,3],"d",width=5) ; n2 <- nomC[ as.integer(vecMdc[i,2]) ] ; n3 <- nomC[ as.integer(vecMdc[i,3]) ] ; fn2 <- sprintf(paste("%-",lngMax,"s",sep=""),n2) fn3 <- sprintf(paste("%-",lngMax,"s",sep=""),n3) #f1bis <- sprintf("%6.4f",vecMdc[i,4]) f1bis <- sprintf("%6.4f",as.numeric(vecMdc[i,4])) if (!vecMdc[i,1]==" NaN") { lesc <- coefficients(lm(dataMatrix[,n2] ~ dataMatrix[,n3])) esp <- " " if (lesc[2]<0) { esp <- "" } # fin si sgnc <- "+" if (lesc[1]<0) { sgnc <- "-" lesc[1] <- (-lesc[1]) } # fin si lesca <- sprintf("%0.3f",lesc[2]) lescb <- sprintf("%0.3f",lesc[1]) if (abs(as.numeric(f1))>stopcor) { cat(f1,"p-value ",f1bis," pour ",fn2," et ",fn3," : ",fn2,"=",esp,lesca,"x",fn3,sgnc,lescb,"\n") ; } # fin de si } # fin de si } # fin pour i } # fin de si } ; # fin de si meilcor=true } ; # fin de si method=pearson } ; # fin de si nc>1 } # fin de fonction mdc ################################################################# bestCorDf <- function(data,method="pearson") { ################################################################# # calcul des plus fortes corrélation de Pearson et Spearman # et transfert dans une matrice triable if (is.null(dim(data))) { rescor <- matrix(nrow=1,ncol=4) return(rescor) } # fin si # s'il y a des facteurs, on les ignore colsClass <- sapply(F=class,X=data) colsNum <- names(data)[colsClass=="numeric"] data <- data[ , colsNum] nbvar <- ncol(data) nbcol <- nbvar*(nbvar-1)/2 rescor <- matrix(nrow=nbcol,ncol=4) colnames(rescor) <- c("var1","var2","pearson","spearman") m1 <- cor(data,method=method) colnames(rescor) <- c("var1","var2","pearson","spearman") if (method=="pearson") { m2 <- cor(data,method="spearman") } else { m2 <- cor(data,method="pearson") colnames(rescor) <- c("var1","var2","spearman","pearson") } # finsi idc <- 0 for (i in 2:nbvar) { for (j in 1:(i-1)) { idc <- idc + 1 rescor[idc,1] <- colnames(data)[i] rescor[idc,2] <- colnames(data)[j] rescor[idc,3] <- m1[i,j] rescor[idc,4] <- m2[i,j] } # fin pour j } # fin pour i idx <- order(1-abs(as.numeric(rescor[,3]))) rescor <- rescor[idx,] if (is.null(dim(rescor))) { rescor <- matrix(rescor,nrow=1,ncol=4) } # fin si return(rescor) } # fin de fonction bestCorDf ################################################################# bestCor <- function(data,method="pearson") { ################################################################# # calcul des plus fortes corrélation de Pearson et Spearman # et transfert dans une matrice triable if (is.null(dim(data))) { rescor <- matrix(nrow=1,ncol=4) return(rescor) } # fin si nbvar <- ncol(data) nbcol <- nbvar*(nbvar-1)/2 rescor <- matrix(nrow=nbcol,ncol=4) colnames(rescor) <- c("var1","var2","pearson","spearman") m1 <- cor(data,method=method) colnames(rescor) <- c("var1","var2","pearson","spearman") if (method=="pearson") { m2 <- cor(data,method="spearman") } else { m2 <- cor(data,method="pearson") colnames(rescor) <- c("var1","var2","spearman","pearson") } # finsi idc <- 0 for (i in 2:nbvar) { for (j in 1:(i-1)) { idc <- idc + 1 rescor[idc,1] <- colnames(data)[i] rescor[idc,2] <- colnames(data)[j] rescor[idc,3] <- m1[i,j] rescor[idc,4] <- m2[i,j] } # fin pour j } # fin pour i idx <- order(1-abs(as.numeric(rescor[,3]))) rescor <- rescor[idx,] if (is.null(dim(rescor))) { rescor <- matrix(rescor,nrow=1,ncol=4) } # fin si return(rescor) } # fin de fonction bestCor ################################################################# maxMatCor <- function(mc,det=FALSE) { ################################################################# # plus grand coefficient de corrélation en valeur absolue hors diagonale vm <- (-2) ilig <- (-1) jcol <- (-1) nbc <- ncol(mc) for (i in 1:nbc) { mc[i,i] <- 0 } # fin pour i cormax <- max(abs(mc)) for (i in 2:nbc) { for (j in 1:(i-1)) { if (abs(mc[i,j])==cormax) { vm <- mc[i,j] ilig <- i jcol <- j } ; # fin si } # fin pour i } # fin pour i if (det){ cat("Valeur maximale dans la matrice de corrélation (hors diagonale) : ",vm," ligne ",ilig," colonne ",jcol,"\n") # cat("soient les variables ",names(mc)[ilig]," et ",names(mc)[jcol],"\n") } # finsi return(list(valmax=vm,lig=ilig,col=jcol)) } # fin de fonction maxMatCor ################################################################# minMatCor <- function(mc,det=FALSE) { ################################################################# # plus petit coefficient de corrélation en valeur absolue cormin <- min(abs(mc)) #cat(" cormin = ",cormin,"\n") vm <- (2) nbc <- ncol(mc) #for (i in 2:nbc) { for (i in 1:nbc) { #for (j in 1:(i-1)) { for (j in 1:nbc) { if (abs(mc[i,j])==cormin) { vm <- mc[i,j] ilig <- i jcol <- j } ; # fin si } # fin pour i } # fin pour i if (det){ cat("Valeur minimale dans la matrice de corrélation : ",vm," ligne ",ilig," colonne ",jcol,"\n") # cat("soient les variables ",names(mc)[ilig]," et ",names(mc)[jcol],"\n") } # finsi return(list(valmin=vm,lig=ilig,col=jcol)) } # fin de fonction minMatCor ################################################################# clusterCor <- function(data,seuil=0.8,methode="pearson",ret=FALSE,...) { ################################################################# # on fait des groupes de variables toutes corrélées entre elles # à au moins r=seuil ; on peut choisir la méthode # si ret=TRUE on renvoie la liste des groupes # voir aussi clusterCorTrans # penser aussi à corclust du package klaR if (missing(data)) { cat(" clusterCor : regroupe les colonnes linéairement corrélées à plus de rho, fourni en paramètre\n") cat(" (valeur par défaut : 0.8)\n") cat(" syntaxe : clusterCor(data,seuil=0.8,methode=\"pearson\") \n\n") stop() } ; # fin si nbc <- ncol(data) cat("\nGroupes de variables fortement corrélées, seuil ",seuil,"\n") cat("pour la corrélation de ",methode,"\n") ind <- rep("",nbc) # individus dans les classes vnu <- rep(1,nbc) # variables non utilisées ndv <- colnames(data) # nom des variables tdh <- rep(0,nbc) # tableau des highest corr tdl <- rep(0,nbc) # tableau des lowest corr nbgrp <- 0 dmOrg <- data mdcOrg <- cor(data,method=methode,...) while ( sum(vnu)>0 ) { # s'il ne reste qu'une seule variable, elle fait un groupe à elle-seule if (sum(vnu)==1) { nbgrp <- nbgrp + 1 lastind <- which(vnu==1) ind[nbgrp] <- lastind vnu[lastind] <- 0 } else { # recherche de la corrélation maximale cm <- maxMatCor(mdcOrg) vmax <- abs(cm$valmax) imax <- cm$lig jmax <- cm$col grp <- c(imax,jmax) nbgrp <- nbgrp + 1 ind[nbgrp] <- vecteurEnChaine(grp) tdh[nbgrp] <- vmax tdl[nbgrp] <- vmax vnu[imax] <- 0 vnu[jmax] <- 0 mdcOrg[imax,jmax] <- 0 mdcOrg[jmax,imax] <- 0 # recherche des variables à rajouter # les variables candidates doivent être corrélées à au moins seuil (ex. 075) dtmp <- dmOrg[,grp] vca <- which(vnu==1) for (idv in vca) { newgrp <- c(grp,idv) newmc <- cor(dmOrg[,newgrp],method=methode,...) vmin <- minMatCor(newmc)$valmin if (abs(vmin)>seuil) { grp <- newgrp vnu[idv] <- 0 # mise à jour du groupe nbgrp ind[nbgrp] <- vecteurEnChaine(grp) ldv <- as.numeric(strsplit(ind[nbgrp],"\\s+",perl=TRUE)[[1]]) tdl[nbgrp] <- vmin mdcOrg[idv,imax] <- 0 mdcOrg[idv,jmax] <- 0 mdcOrg[imax,idv] <- 0 mdcOrg[jmax,idv] <- 0 } # fin si } # fin pour idv # on ne doit plus utiliser les corrélations avec les variables du groupe for (jdc in grp) { for (kdc in 1:nbc) { mdcOrg[jdc,kdc] <- 0 mdcOrg[kdc,jdc] <- 0 } # fin pour kdc } # fin pour jdc # on garde les variables non utilisées data <- dmOrg[,which(vnu==1)] } # fin si } ; # fin de tant que # affichages cat("\nGroup | Count | Highest r | Lowest r | Variables\n") saut <- 0 indvus <- c() grps <- list() numg <-0 for (idgrp in 1:nbgrp) { numg <- numg + 1 ldv <- as.numeric(strsplit(ind[idgrp],"\\s+",perl=TRUE)[[1]]) if (abs(tdh[idgrp])<=seuil) { saut <- saut + 1 } if (saut==0) { indvus <- c(indvus,ldv) } if (saut==1) { cat("\n") } # fin si cat(sprintf("%4d | ",numg)) cat(sprintf(" %3d | ",length(ldv))) cat(sprintf(" %7.3f | ",tdh[idgrp])) if (tdl[idgrp]==tdh[idgrp]) { cat(rep(" ",9),"| ",sep="") } else { cat(sprintf("%7.3f | ",tdl[idgrp])) } # fin si nomg <- paste("group",numg,sep="") nomvars <- "" vecvars <- c() for (idv in ldv) { nomvars <- paste(nomvars,ndv[idv]) vecvars <- c(vecvars,ndv[idv]) } # fin pour cat(ghtrim(nomvars),"\n") grps[[numg]] <- vecvars } # fin pour idg if (ret) { return(grps) } # fin si } # fin de fonction clusterCor ################################################################# clusterCorTrans <- function(data,seuil=0.8,methode="pearson",detail=FALSE,ret=FALSE,garde=FALSE,...) { ################################################################# # on fait des groupes de variables toutes corrélées entre elles # mais avec un regroupement transitif (par propagation) # si ret=TRUE on renvoie la liste des groupes # si ret=FALSE et garde=TRUE on renvoie la matrice réduite # voir aussi clusterCorTrans # penser aussi à corclust du package klaR if (missing(data)) { cat(" clusterCorTrans : regroupe les colonnes linéairement corrélées par propagation, à plus de rho, fourni en paramètre\n") cat(" (valeur par défaut : 0.8)\n") cat(" syntaxe : clusterCorTrans(data,seuil=0.8,methode=\"pearson\") \n\n") stop() } ; # fin si matdata <- data rho <- seuil cat("\nRegroupement transitif de variables fortement corrélées au seuil rho=",rho,"\n") cat("pour la corrélation de ",methode,"\n") nbcol <- ncol(matdata) nomcol <- names(matdata) colatrait <- rep(1,nbcol) colvues <- rep(2,nbcol) # 2 : colonne non vue, 1 en cours, 0 déja traitée lesgrp <- rep(0,nbcol) # numéro du groupe # on passe les colonnes en revue : celles qui sont à plus de rho sont mises # ensemble (une étoile) ; on met alors colatrait (colonnes à traiter) à 0 et on # recommence avec les variables du groupe apr tarnsitivité (deux étoiles) jusqu'à saturation # puis on passe au groupe suivant ... nb1 <- sum(colatrait==1) grps <- list() grp <- 0 # numéro de groupe while (nb1>0) { ibase <- 1 while (ibase<=nbcol) { if (colatrait[ibase]==1) { itrait <- ibase ibase <- nbcol + 1 } # fin de si sur colonne à traiter ibase <- ibase + 1 } # fin tant que sur ibase grp <- grp + 1 eff <- 1 vi <- matdata[,itrait] colvues[itrait] <- 0 cat("\nGroupe ",sprintf("%2d",grp)," : ") cat(" ",nomcol[itrait]) lesgrp[itrait] <- grp vecvars <- nomcol[itrait] if (itrait<=nbcol) { colatrait[itrait] <- 0 # premier passage eff <- 0 if (itrait+1<=nbcol) { pdvj <- (itrait+1):nbcol for (j in pdvj) { vj <- matdata[,j] corij <- cor(vi,vj,method=methode,...) if (abs(corij)>=rho) { colvues[j] <- 1 cat(" *",nomcol[j]) vecvars <- c(vecvars,nomcol[j]) lesgrp[j] <- grp eff <- eff + 1 } # fin de si } # fin pour j } # fin si # deuxieme passage (transitivité faible de rho) nb2 <- sum(colvues==1) jtrait <- nbcol+1 while (nb2>0) { jbase <- 1 while (jbase<=nbcol) { if ( (colvues[jbase]==1) & (colatrait[jbase]==1) ) { jtrait <- jbase jbase <- nbcol + 1 colvues[jtrait] <- 0 colatrait[jtrait] <- 0 } # fin de si sur colonne à traiter jbase <- jbase + 1 } # fin tant que sur jbase nb3 <- sum(colvues==1) if (jtrait<=nbcol) { vjt <- matdata[,jtrait] for (j in (1:nbcol)) { if (colvues[j]==2) { if (colatrait[j]==1) { vj <- matdata[,j] corij <- cor(vjt,vj,method=methode,...) if (abs(corij)>=rho) { colvues[j] <- 1 cat(" **",nomcol[j]) lesgrp[j] <- grp vecvars <- c(vecvars,nomcol[j]) } # fin de si } # fin de si } # fin de si } # fin pour j } # fin si nb2 <- sum(colvues==1) } # fin de tant que } # fin de si on a au moins une colonne à traiter nb1 <- sum(colatrait==1) grps[[grp]] <- vecvars } # fin de tant que cat("\n") # msie en forme des résultats retenue <- rep(0,nbcol) gard <- rep(0,grp) for (igrp in (1:grp)) { icol <- 1 igard <- 0 while (icol<=nbcol) { if (lesgrp[icol]==igrp) { igard <- icol icol <- nbcol + 1 } # fin si icol <- icol + 1 } # fin tant que gard[igrp] <- igard retenue[igard] <- igrp } # fin pour mret <- cbind(lesgrp,retenue) row.names(mret) <- names(matdata) colnames(mret) <- c("Groupe","Variable retenue") if (detail) { cat("\n") cat("Numéros de groupe de corrélation et variable retenue : \n") print(mret) cat("\n") cat("On retient ",grp," variables :") } # fin si mgarde <- matdata[,gard] cat("\nRésumé des dimensions\n") cat(" données initiales : ",sprintf("%5d",dim(matdata)),"\n") cat(" données finales : ",sprintf("%5d",dim(mgarde)),"\n\n") if (ret) { return(grps) } else { if (garde) { return(mgarde) } # fin si } # fin si } # fin de fonction clusterCorTrans ################################################################# ################################################################# dfSansCor <- function(dataMatrix,details=FALSE) { ################################################################# nbvar <- ncol(dataMatrix) keepv <- rep(TRUE,nbvar) pdv <- 1:(nbvar-1) for (idv in pdv) { if (keepv[idv]) { pdv2 <- (1+idv):nbvar for (jdv in pdv2) { pv <- cor.test(dataMatrix[,idv],dataMatrix[,jdv])$p.value if (pv<0.05) { keepv[jdv] <- FALSE } # fin si } # fin pour jdv } # fin si } # fin pour idv nomcol <- colnames(dataMatrix) keepData <- dataMatrix[,nomcol[keepv],drop=FALSE] cat("Variables de départ : ",colnames(dataMatrix),"\n") cat("Variables conservées : ",colnames(keepData),"\n") cat("Vérification :\n") ; mdc(keepData,meilcor=TRUE) if (details) { cat("A titre de comparaison, voici la matrice de corrélation initiale et ses p-values\n") mdc(dataMatrix,meilcor=TRUE) } # fin de si } # fin de fonction dfSanCor ################################################################# reduitVarsCor <- function(matdata,rho=0.8,file="",methode="pearson") { ################################################################# # on retire les variables fortement corrélées du dataframe if (missing(matdata)) { cat(" reduitVars : élimine les colonnes linéairement corrélées à plus de rho, fourni en paramètre\n") cat(" (valeur par défaut : 0.8)\n") cat(" syntaxe : reduitVars(matdata,rho=0.8,file=\"\",methode=\"pearson\") \n\n") stop() } ; # fin si cat("\nRéduction du nombre de variables par suppression des variables fortement corrélées au seuil rho=",rho) cat("\npour la corrélation de ",methode,"\n\n") matdataorg <- matdata nbcol <- ncol(matdata) colasup <- c() for (i in 1:(nbcol-1)) { vi <- matdata[,i] nomi <- sprintf("%-12s",names(matdata)[i]) for (j in (i+1):nbcol) { vj <- matdata[,j] corij <- cor(vi,vj,use="pairwise.complete.obs",method=methode) if (abs(corij)>=rho) { nomj <- sprintf("%-12s",names(matdata)[j]) cat(" la colonne ",sprintf("%5d",j)," soit ",nomj," est éliminée car fortement corrélée à ") cat("la colonne ",sprintf("%5d",i)," soit ",nomi," : rho = ",sprintf("%6.3f",corij),"\n") colasup <- c(colasup,j) } # fin de si } # fin pour j } # fin pour i newmatdata <- matdata cat(" réduction : ") nbcolasup <- length(colasup) if (nbcolasup>0) { colasup <- rev(sort(unique(colasup))) nbcolasup <- length(colasup) if (nbcolasup==1) { cat(nbcolasup," colonne fortement corrélée linéairement supprimée \n") } else { cat(nbcolasup," colonnes fortement corrélées linéairement supprimées \n") } # fin si #print( colasup ) for (jcol in colasup) { newmatdata <- newmatdata[,-jcol] } # fin pour jcol } else { cat(" pas de colonnes fortement corrélées linéairement supprimées \n") } # fin si # recherche de la plus forte corrélation restante # affichage des dimensions avant et après cat("\nRésumé des dimensions\n") cat(" données initiales : ",sprintf("%5d",dim(matdataorg)),"\n") cat(" données finales : ",sprintf("%5d",dim(newmatdata)),"\n\n") nomi <- colnames(newmatdata)[1] nomj <- colnames(newmatdata)[1] maxcor <- 0 nbcol <- ncol(newmatdata) for (i in 1:(nbcol-1)) { vi <- newmatdata[,i] for (j in (i+1):nbcol) { vj <- newmatdata[,j] corij <- cor(vi,vj,use="pairwise.complete.obs",method=methode) if (abs(corij)>=abs(maxcor)) { maxcor <- corij imax <- i jmax <- j nomi <- colnames(newmatdata)[i] nomj <- colnames(newmatdata)[j] } # fin de si } # fin pour j } # fin pour i cat(" le plus fort coefficient de corrélation restant est ",sprintf("%6.3f",maxcor),"\n") cat(" et met en jeu les colonnes ",imax," et ",jmax," soit ",nomi," et ",nomj,"\n\n") if (file!="") { write.table(newmatdata,file=file,quote=FALSE,) cat("les données finales ont été écrites dans le fichier ",file,"\n") } ; # fin si cat("les ",ncol(newmatdata),"colonnes restantes sont : \n") cat(colnames(newmatdata),"\n") return(newmatdata) } # fin de fonction reduitVarsCor ################################################################# exploreCorrelations <- function(titre,data,couleurs=NULL) { ################################################################# library(corrplot) # pour la fonction corrplot library(corrgram) # pour la fonction corrgram library(klaR ) # pour la fonction corclust ## mdc(data) # fonction (GH) ##if (!is.null(couleurs)) { pairsi(data,1,col=couleurs) } ##pairsi(data,2) ##pairsi(data,3) mcorp <- cor(data,method="pearson") mcors <- cor(data,method="spearman") titrep <- paste(titre,"Pearson correlation") titres <- paste(titre,"Spearman correlation") corrplot(mcorp,main=titrep) corrplot(mcors) title(titres) corCircle("FCS ISHAK",data) corrgram(mcorp,main="Pearson") corrgram(mcors,main="Spearman") cat("\n\nMatrix for 1-min absolute corr. within cluster\n") corclust(data) } # fin de fonction exploreCorrelations ################################################################# mcomed <- function(dataMatrix,nomV,meilcor=TRUE) { ################################################################# # matrice des comédianes # # nomV est le nom des variables # exemple d'utilisation : # # mcomed(lesQT,c("AGE","POIDS","TAILLE","ALCOOL")) # dm <- dim(dataMatrix) ; nl <- dm[1] nc <- dm[2] resMat <- matrix(nrow=nc,ncol=9) comMat <- matrix(nrow=nc,ncol=nc) ; rownames(comMat) <- as.vector(nomV) colnames(comMat) <- nomV meiCor <- (-3) iEtj <- "-99" for (i in 1:nc) { vi <-- dataMatrix[,i] for (j in 1:nc) { if (i<j) { com <- "" } else { vj <-- dataMatrix[,j] com <- formatC(comed(vi,vj),"f",width=5,dig=3) } ; # fin de si sur i<j comMat[i,j] <- com } # fin pour j } # fin pour i cat("\nMatrice des comédianes\n") ; print(comMat,quote=FALSE,right=TRUE) ; } # fin de fonction mcomed ################################################################# moy <- function(vecteurQt) { ################################################################# # un simple synonyme pour mean return( mean( vecteurQt ) ) } ; # fin de fonction moy ################################################################# cr <- function(vecteurQt) { ################################################################# # centre et réduit un vecteur return( (vecteurQt - mean( vecteurQt )) / sd(vecteurQt) ) } ; # fin de fonction cr ################################################################# histoQT <- function(titreQT, vecteurQT,unite="",grfile="",lang="FR",maxhist=0,rug=TRUE,...) { ################################################################# # un histogramme amélioré pour les QT # avec loi normale et densité if (!grfile=="") { gr(grfile) } densQT <- density(vecteurQT) #borne <- densQT$bw*1.3 # 1.3 est intuitif borne <- 1 #hist(vecteurQT,col="light blue",probability = TRUE,main="Histogramme des classes",xlab="",ylab="",ylim=c(0,borne)) if (lang=="FR") { titre <- "Histogramme pour " } else { titre <- "Histogram of " } # finsi titre <- paste(titre,titreQT," (",length(vecteurQT)," val.)",sep="") if (maxhist==0) { vmaxhist <- max(hist(vecteurQT,plot=FALSE)$density)*1.9 } else { vmaxhist <- maxhist } # fin si hist(vecteurQT,col="light blue",probability = TRUE,main=titre,xlab="",ylab="",ylim=c(0,vmaxhist),...) vnorm <- function(x) { dnorm(x,mean=mean(vecteurQT),sd=sd(vecteurQT)) } curve(vnorm,add=TRUE,col="red",lwd=2) lines(densQT,col="blue") if (rug) { rug(vecteurQT) } if (lang=="FR") { leg <- c("densité","loi normale") } else { leg <- c("density","normal distribution") } # finsi legend(x="topright",leg,col=c("blue","red"),lty=c(1,1),bty="n") if (!grfile=="") { dev.off() cat("\n vous pouvez utiliser ",grfile,"\n") } ; # fin de si } ; # fin de fonction histoQT ################################################################# plotQT <- function(titreQT, vecteurQT,unite="",tigef=FALSE,ylims=0,grfile="",lang="FR",lstem=100) { ################################################################# # # un "plot" amélioré pour les QT # avec rappel des caractéristiques et tige/feuille éventuel et # boxplot éventuel if (!grfile=="") { png(grfile,width=1024,height=768) } if (tigef) { par(mfrow=c(1,2)) } else { par(mfrow=c(1,1)) } ; # fin de si letitreQT <- paste("Variable ",titreQT," (",unite,")",sep="") if (length(ylims)==1) { plot(sort(vecteurQT),main=letitreQT,col="blue",xlab="",ylab="") } else { plot(sort(vecteurQT),main=letitreQT,col="blue",xlab="",ylab="",ylim=ylims) } abline(c(mean(vecteurQT,na.rm=TRUE),0),col="red",lw=2) abline(c(median(vecteurQT,na.rm=TRUE),0),col="green") if (lang=="FR") { cat("\n la moyenne est en rouge, la médiane en vert \n\n") } else { cat("\n red: mean; green: median.\n\n") } # finsi if (tigef) { if (lang=="FR") { cat("\n Tracé tige et feuilles\n") } else { cat("\n Steam and Leaf diagram\n") } # finsi if (length(vecteurQT)<100) { stem(vecteurQT) } else { stem(vecteurQT,width=lstem) } # fin si boxplotQT(titreQT,vecteurQT,ylims) } ; # fin de si if (!grfile=="") { dev.off() cat("\n vous pouvez utiliser ",grfile,"\n") } ; # fin de si } ; # fin de fonction plotQT ################################################################# plotQTdet <- function(titreQT, vecteurQT,unite="",tigef=FALSE,grfile="",ylims=0,maxhist=0,msg="oui",lng="FR",rug=TRUE,lngstem=80) { ################################################################# # # un "plot" amélioré et détaillé pour les QT # avec rappel des caractéristiques et tige/feuille éventuel et # boxplot éventuel if (!grfile=="") { png(grfile,width=1200,height=800) } if ((unite=="?")|(nchar(unite)==0)|(unite==" ")|(unite=="")) { leTitreQT <- titreQT } else { leTitreQT <- paste(titreQT," (",unite,")",sep="") } # finsi par(mfrow=c(2,2)) # 1. tracé trié if (length(ylims)==1) { plot(sort(vecteurQT),main=leTitreQT,col="blue",xlab="",ylab="") } else { plot(sort(vecteurQT),main=leTitreQT,col="blue",xlab="",ylab="",ylim=ylims) } abline(c(mean(vecteurQT),0),col="red",lw=2) abline(c(median(vecteurQT),0),col="green") if (lng=="FR") { legend(x="topleft",c("moyenne","médiane"),col=c("red","green"),lty=c(1,1),bty="n") } else { legend(x="topleft",c("mean","median"),col=c("red","green"),lty=c(1,1),bty="n") } # finsi #cat("\n la moyenne est en rouge, la médiane en vert \n\n") # 2. Histogramme par classe # density(vecteurQT)$bw*1.3 densQT <- density(vecteurQT) #borne <- densQT$bw*1.3 # 1.3 est intuitif borne <- 1 #hist(vecteurQT,col="light blue",probability = TRUE,main="Histogramme des classes",xlab="",ylab="",ylim=c(0,borne)) if (lng=="FR") { titre <- "Histogramme des classes pour " titreQTbp <- paste("Boite à moustaches pour ",leTitreQT,sep="") } else { titre <- "Histogram of " titreQTbp <- paste("Boxplot of ",leTitreQT,sep="") } # finsi titre <- paste(titre,leTitreQT,sep="") if (maxhist==0) { hist(vecteurQT,col="light blue",probability = TRUE,main=titre,xlab="",ylab="") } else { hist(vecteurQT,col="light blue",probability = TRUE,main=titre,xlab="",ylab="",ylim=c(0,maxhist)) } # fin si vnorm <- function(x) { dnorm(x,mean=mean(vecteurQT),sd=sd(vecteurQT)) } curve(vnorm,add=TRUE,col="red",lwd=2) lines(densQT,col="blue") if (lng=="FR") { leg <- c("densité","loi normale") } else { leg <- c("density","normal distribution") } # finsi legend(x="topright",leg,col=c("blue","red"),lty=c(1,1),bty="n") if (rug) { rug(vecteurQT) } # 3. Boite à moustaches if (tigef) { if (lng=="FR") { cat("\n Tracé tige et feuilles\n") } else { cat("\n Steam and Leaf diagram\n") } # finsi if (length(vecteurQT)<100) { stem(vecteurQT) } else { stem(vecteurQT,width=lngstem) } # fin si } ; # fin de si boxplotQT(titreQTbp,vecteurQT,lng=lng,unitQT=unite) # 4. Droite de Henry if (lng=="FR") { titre <- paste("Droite de Henry pour ",leTitreQT,sep="") } else { titre <- paste("Q-Q Plot for ",leTitreQT,sep="") } # finsi qqnorm(vecteurQT, main=titre,xlab="",ylab="") qqline(vecteurQT, col="red",lwd=2) if (!grfile=="") { dev.off() if (msg=="oui") { cat("\n vous pouvez utiliser ",grfile,"\n") } # fin si } ; # fin de si } ; # fin de fonction plotQTdet ################################################################# bbpQT <- function(titreQT, vecteurQT,grfile="",msg="oui",lng="FR") { ################################################################# if (!grfile=="") { png(grfile,width=1200,height=800) } par(mfrow=c(1,2)) boxplotQT(titreQT,vecteurQT,lng=lng) beanplotQT(titreQT,vecteurQT,lng=lng) if (!grfile=="") { dev.off() if (msg=="oui") { cat("\n vous pouvez utiliser ",grfile,"\n") } } ; # fin de si } ; # fin de fonction bbpQT ################################################################# hbbpQT <- function(titreQT, vecteurQT,grfile="",msg="oui",lng="FR") { ################################################################# if (!grfile=="") { png(grfile,width=1200,height=800) } par(mfrow=c(3,1)) histoQT(titreQT,vecteurQT) boxplotQT(titreQT,vecteurQT) beanplotQT(titreQT,vecteurQT) if (!grfile=="") { dev.off() if (msg=="oui") { cat("\n vous pouvez utiliser ",grfile,"\n") } } ; # fin de si } ; # fin de fonction hbbpQT ################################################################# traceLin <- function(titreVar1,varQT1,titreVar2,varQT2,graphique=FALSE,couleurs=0,xmin=min(varQT1),xmax=max(varQT1),ymin=min(varQT2),ymax=max(varQT2)) { ################################################################# # # affiche et trace la corrélation linéaire entre deux QT # dans le sens fourni. exemple d'utilisation : # # tracelin("TAILLE",taille,"POIDS",poi) # # on n'affiche aucun résultat statistique # la version "dans les deux sens" se nomme analin # a1 <- lm( varQT2 ~ varQT1 ) cdc <- cor(varQT1,varQT2) fcdc <- sprintf("%5.2f",cdc) idx <- order(varQT1) newX <- varQT1[idx] newY <- varQT2[idx] va <- sprintf("%5.2f",a1$coefficients[2]) vb <- sprintf("%5.2f",a1$coefficients[1]) equ1 <- paste(" équation : ",titreVar2," = ",va,"*",titreVar1," + ",vb," (",length(varQT1)," valeurs)",sep="") cat(equ1) cat("\n") if (graphique) { rangex <- c(xmin,xmax) rangey <- c(ymin,ymax) if (length(couleurs)==1) { plot(newX,newY,type="p",col="red",pch=21,bg="orange",fg="black",xlab=titreVar1,ylab=titreVar2,xlim=rangex,ylim=rangey) } else { newC <- couleurs[idx] plot(newX,newY,type="p",col="black",pch=21,bg=newC,fg="black",xlab=titreVar1,ylab=titreVar2,xlim=rangex,ylim=rangey) } # finsi title(paste(" Régression pour ",titreVar1," et ",titreVar2," (rho=",fcdc,")\n",equ1)) abline(a1,col="blue") # tracé des intervalles de confiance dflm <- data.frame( cbind(varQT1,varQT2) ) colnames(dflm) <- c("xx","yy") ml <- lm(yy~xx,data=dflm) grillex <- data.frame(xx=rangex) icConf <- predict(ml,new=grillex,interval="confidence",level=0.95) icPred <- predict(ml,new=grillex,interval="prediction",level=0.95) matlines(grillex,cbind(icConf,icPred[,-1]),lty=c(1,2,2,3,3),col=c("black","red","red","green","green"),lwd=2) } ; # fin de si } ; # fin de fonction traceLin ################################################################# vvar <- function(vecteurQt) { ################################################################# # # la "vraie" variance mathématique, "non biaisée" # nommée aussi variance empirique, variance exacte # en opposition à la variance estimée return( mean( (vecteurQt- mean(vecteurQt,na.rm=TRUE))^2 ,na.rm=TRUE) ) } ; # fin de fonction vvar ################################################################# ################################################################# ################################################################# ## ## ## FONCTIONS pour APPROXIMATIONS et TESTS ## ## ## ################################################################# ################################################################# ################################################################# approximations <- function() { ################################################################# cat("Fonctions pour approximations : \n") ; cat(" approximationBinomiale() approximationPoissonnienne() approxPoissNorm() simule() \n\n") ; } ; # fin de fonction approx ################################################################# approximationBinomiale <- function(titre,effectifs,ymax) { ################################################################# if (missing(titre)) { cat(" Il manque au moins le titre ; syntaxe de la fonction :\n") cat(" approximationBinomiale(titre,effectifs,ymax)\n\n") } else { cats("Approximation d'efffectifs en classes par une loi binomiale") vobs <- effectifs nbcl <- length(vobs) plagecl <- 0:(nbcl-1) somVal <- sum(vobs) cat(somVal,"valeurs vues pour",nbcl,"classes\n\n") cats("Distribution des données observées","-") tdr <- rbind( vobs,round(100*vobs/somVal,1)) colnames(tdr) <- plagecl row.names(tdr) <- c("Effectifs","Fréquences") print(tdr) mp <- sum(plagecl*vobs)/somVal cat("\nMoyenne pondérée = ",mp,"\n") pr <- mp/nbcl cat("la loi binomiale candidate a donc comme paramètres n=",nbcl," et p=",pr,"\n\n",sep="") cats("Distribution des données observées et attendues","-") edp <- round(somVal*dbinom(plagecl,nbcl,pr)) sumExp <- sum(edp) tdr <- cbind(vobs,round(100*vobs/somVal,1), edp,round(100*edp/somVal,1)) tdr <- rbind(tdr,colSums(tdr)) row.names(tdr) <- c(plagecl,"total") colnames(tdr) <- c("Obs","Freq","The","Freq") print(tdr) if (sumExp!=somVal) { nval <- somVal-sumExp cat("\nIl manque à la loi binomiale ",nval," valeurs que l'on ajoute en classe ",(nbcl-1),".\n",sep="") edp[nbcl] <- edp[nbcl] + nval cat("\nNouveau tableau des distributions : \n") sumExp <- sum(edp) tdr <- cbind(vobs,round(100*vobs/somVal,1), edp,round(100*edp/somVal,1)) tdr <- rbind(tdr,colSums(tdr)) row.names(tdr) <- c(plagecl,"total") colnames(tdr) <- c("Obs","Freq","The","Freq") print(tdr) } # fin de si chi2Adeq(vth=edp,vobs=vobs,contr=TRUE,graph=TRUE,fichier="approx_binom",ymax=ymax,titre="Approximation binomiale") } # fin de si } ; # fin de fonction approximationBinomiale ################################################################# approximationPoissonnienne <- function(titre="",effectifs,ymax=100) { ################################################################# if (missing(titre)) { cat(" Il manque au moins le titre ; syntaxe de la fonction :\n") cat(" approximationPoissonnienne(titre,effectifs,ymax)\n\n") } else { cats("Approximation d'efffectifs en classes par une loi de Poisson tronquée") vobs <- effectifs nbcl <- length(vobs) plagecl <- 0:(nbcl-1) somVal <- sum(vobs) cat(somVal,"valeurs vues pour",nbcl,"classes\n\n") cats("Distribution des données observées","-") tdr <- rbind( vobs,round(100*vobs/somVal,1)) colnames(tdr) <- plagecl row.names(tdr) <- c("Effectifs","Fréquences") print(tdr) lam <- sum(plagecl*vobs)/somVal cat("\nMoyenne pondérée = lambda =",lam,"\n") cats("Distribution des données observées et attendues","-") edp <- round(somVal*dpois(plagecl,lam)) sumExp <- sum(edp) tdr <- cbind(vobs,round(100*vobs/somVal,1), edp,round(100*edp/somVal,1)) tdr <- rbind(tdr,colSums(tdr)) row.names(tdr) <- c(plagecl,"total") colnames(tdr) <- c("Obs","Freq","The","Freq") print(tdr) if (sumExp!=somVal) { nval <- somVal-sumExp cat("\nIl manque à la loi de Poisson tronquée ",nval," valeurs que l'on ajoute en classe ",(nbcl-1),".\n",sep="") edp[nbcl] <- edp[nbcl] + nval cat("\nNouveau tableau des distributions : \n") sumExp <- sum(edp) tdr <- cbind(vobs,round(100*vobs/somVal,1), edp,round(100*edp/somVal,1)) tdr <- rbind(tdr,colSums(tdr)) row.names(tdr) <- c(plagecl,"total") colnames(tdr) <- c("Obs","Freq","The","Freq") print(tdr) } # fin de si chi2Adeq(vth=edp,vobs=vobs,contr=TRUE,graph=TRUE,fichier="approx_poiss",ymax=ymax,titre="Approximation de Poisson") } # fin de si } ; # fin de fonction approximationPoissonnienne ################################################################# approxPoissNorm <- function(lambda,nbpoints,nbcla) { ################################################################# # Approximation de la loi de Poisson par la loi normale par(mfrow=c(1, 2)) tirage <- rpois(nbpoints,lambda) flambda <- formatC(lambda,format="d") slambda <- formatC(sqrt(lambda),format="f",digits=2) hist(tirage, col="blue", main=paste("Histogramme des fréquences"), xlab=" valeurs seules",ylab="effectifs",breaks=nbcla) vxp <- lambda-3*sqrt(lambda) vxg <- lambda+3*sqrt(lambda) vx <- seq(vxp,vxg,length=nbpoints) vy <- dnorm(vx,mean=lambda-2,sd=sqrt(lambda)) xmin <- min(vx) xmax <- max(vx) ymin <- min(vy) ymax <- max(vy) hist(tirage, col="blue", main=paste("Approximation de la loi de Poisson par la loi normale, lambda=",flambda),breaks=nbcla) # fin de hist par(new=TRUE) plot(vx,vy,type="l",col="red",lwd=2,axes=FALSE,xlim=c(xmin,xmax),ylim=c(ymin,ymax)) par(mfrow=c(1, 1)) } ; # fin de fonction approxPoissNorm ################################################################# chi2 <- function() { ################################################################# # # rappel des diverses fonctions pour le chi2 # cat("\n Vous disposez de trois fonctions chi2 : \n") cat("\n chi2Adeq ") cat("\n pour la comparaison entre valeurs observées") cat("\n et valeurs théoriques") cat("\n syntaxe : chi2Adeq(vth,vobs,contr=FALSE) \n") cat("\n") cat("\n chi2Indep ") cat("\n pour tester l'indépendance entre deux variables qualitatives") cat("\n syntaxe : chi2Indep(var1,var2,modal1,modal2) \n") cat("\n") cat("\n chi2IndepTable ") cat("\n pour tester l'indépendance entre deux variables qualitatives") cat("\n lorsqu'on fournit le tri croisé des variables qualitatives") cat("\n syntaxe : chi2IndepTable( table(var1,var2),modal1,modal2 ) \n") cat("\n") } ; # fin de fonction chi2 ################################################################# chi2Adeq <- function(vth,vobs,contr=FALSE,graph=FALSE,ymax=100,basefichier="",titre="",noms=c(),longueur=1600,largeur=1200) { ################################################################# # # calcul du chi-deux d'adéquation classique # on détaille les contributions au chi-deux # pour bien comprendre "là où ça varie" cat("\n CALCUL DU CHI-DEUX D'ADEQUATION\n") cat("\n Valeurs théoriques ",vth) cat("\n Valeurs observées ",vobs) # le calcul n'est licite que si # c1 : les vecteurs ont même somme... sthe <- sum(vth) sobs <- sum(vobs) if (abs(sthe-sobs)>10**(-3)) { cat("\n") cat("\n les valeurs théoriques et observées n'ont pas la même somme\n") ; cat("\n somme des valeurs théoriques ",sthe,"") ; cat("\n somme des valeurs observées ",sobs," \n") ; cat("\n différence : ",sthe-sobs,"\n") cat("\n le calcul du chi-deux n'est donc pas possible.\n") ; cat("\n") return(-1) } ; # fin de si # c2 : et s'ils sont même longueur lthe <- length(vth) lobs <- length(vobs) if (!lthe == lobs) { cat("\n") cat("\n les valeurs théoriques et observées n'ont pas la même longueur\n") ; cat("\n longueur des valeurs théoriques ",lthe,"") ; cat("\n longueur des valeurs observées ",lobs," \n") ; cat("\n le calcul du chi-deux n'est donc pas possible.\n") ; cat("\n") } ; # fin de si # c3 : s'il n'y a pas d'effectif inférieur à 5 # si on arrive ici, le calcul est sans doute possible... vchi <- sum ((vth-vobs)**2/vth) alpha <- 5 pval <- chisq.test( vobs, p=vth/sthe )$p.value chi2m <- qchisq( 1 -alpha/100, lthe-1 ) cat("\n Valeur du chi-deux ",vchi,"\n") cat("\n Chi-deux max (table) à 5 % ",chi2m ) cat(" pour ",lthe-1," degrés de liberté ; p-value ", pval) cat("\n") # une petite phrase pour conclure le test cat("\n décision : au seuil de ",alpha,"%") if (vchi<=chi2m) { cat(" on ne peut pas rejeter l'hypothèse") } else { cat(" on peut rejeter l'hypothèse") } ; # fin de si cat("\n que les données observées correspondent aux valeurs théoriques.\n") cat("\n") # on affiche en détail du calcul du chi-deux # si l'une des trois conditions au moins est remplie # 1. contr est à TRUE # 2. la p-value est inférieure à 0.05 # 3. la valeur du chi2 dépasse celle de la table cnd1 <- contr cnd2 <- pval < 0.05 cnd3 <- vchi > chi2m cond <- cnd1 | cnd2 | cnd3 # affichage éventuel des contributions if (contr) { cat("\n Contributions au chi-deux \n\n") nc <- 7 cntr <- data.frame(matrix(nrow=lthe,ncol=nc)) colnames(cntr) <- c("Ind.","The","Obs","Dif","Cntr","Pct","Cumul") #rownames(cntr) <- rep(" ",lthe) rownames(cntr) <- 1:lthe scnt <- 0 for (i in 1:lthe) { cntr[i,1] <- noms[i] cntr[i,2] <- vth[i] cntr[i,3] <- vobs[i] dif <- vth[i] - vobs[i] cntr[i,4] <- (- dif) # modif 2020 cntr[i,5] <- dif**2/vth[i] cntr[i,6] <- 100.0*(cntr[i,5]/vchi) scnt <- scnt + cntr[i,5] cntr[i,7] <- scnt } ; # fin pour i print(cntr) cat("\n") cat("\n Contributions triées \n\n") idx <- order(cntr[,5],decreasing=TRUE) print(cntr[idx,]) } ; # fin de si # affichage éventuel des histogrammes avec stockage en image PNG if (graph) { if (basefichier!="") { png1 <- paste(basefichier,"1.png",sep="") #png(png1,width=1024,height=768) gr(png1,longueur,largeur) } # finsi scr(2) vth2 <- 100*vth/sthe names(vth2) <- 0:(lthe-1) if (length(noms)>0) { names(vth2) <- noms } maintr <- "E. observés (bleu) vs théoriques (rouge) en %" if (titre!="") { maintr <- paste(titre," : effectifs (%)") } # fin de si #print(vth2) #cat("ymax vaut ",ymax,"\n") barplot(round(vth2),col="red",main=maintr,ylim=c(0,ymax)) vobs2 <- 100*vobs/sthe names(vobs2) <- 0:(lthe-1) if (length(noms)>0) { names(vobs2) <- noms } barplot(vobs2,col="blue",main=maintr,ylim=c(0,ymax)) if (basefichier!="") { dev.off() } # finsi if (basefichier!="") { png2 <- paste(basefichier,"2.png",sep="") #png(png2,width=1024,height=768) gr(png2,longueur,largeur) } # finsi scr(1) vatr <- rbind(vobs2,vth2) if (length(noms)>0) { colnames(vatr) <- noms } maintr <- "Effectifs observés (bleu) vs théoriques (rouge) en %)" if (titre!="") { maintr <- paste(titre," : effectifs observés (bleu) vs théoriques (rouge) en %)") } # fin de si barplot(vatr,col=c("blue","red"),beside=TRUE, main=maintr,ylim=c(0,ymax)) if (basefichier!="") { dev.off() cat(" Vous pouvez utiliser ",png1," et ",png2,"\n") } # finsi } ; # fin de si } ; # fin de fonction chi2Adeq ################################################################# chi2Indep <- function(var1,var2,modal1,modal2) { ################################################################# # # un simple appel de la fonction suivante # chi2IndepTable( table(var1,var2),modal1,modal2 ) } ; # fin de fonction chi2Indep ################################################################# chi2IndepTable <- function(tcr,mo1="",mo2="") { ################################################################# # # calcul du chi-deux d'indépendance classique # MAIS : on détaille les contributions au chi-deux cat("\nCALCUL DU CHI-DEUX D'INDEPENDANCE\n") nbl <- dim(tcr)[1] nbc <- dim(tcr)[2] mtric <- matrix(nrow=nbl+1,ncol=nbc+1) for (i in (1:nbl)) { for (j in (1:nbc)) { mtric[i,j] <- tcr[i,j] } ; # fin pour sur j } ; # fin pour sur i if (length(mo1)==1) { mo1 <- 1:nbl } if (length(mo2)==1) { mo2 <- 1:nbc } rownames(mtric) <- c(mo1,"Total") colnames(mtric) <- c(mo2,"Total") valt <- matrix(nrow=nbl+1,ncol=nbc+1) rownames(valt) <- c(mo1,"Total") colnames(valt) <- c(mo2,"Total") soml <- matrix(nrow=nbl,ncol=1) somc <- matrix(nrow=nbc,ncol=1) # calcul des marges en ligne for (i in (1:nbl)) { sl <- sum( tcr[i,] ) soml[ i ] <- sl valt[ i , nbc + 1 ] <- sl mtric[ i , nbc + 1 ] <- sl } ; # fin pour sur i # total colonne for (j in (1:nbc)) { sc <- sum( tcr[,j] ) somc[ j ] <- sc valt[ nbl + 1 , j ] <- sc mtric[ nbl + 1 , j ] <- sc } ; # fin pour sur j # total général tg <- sum(tcr) valt[nbl+1,nbc+1] <- tg mtric[nbl+1,nbc+1] <- tg cat("\nTableau des données \n\n") print(mtric,right=TRUE,print.gap=3) # remplissage des valeurs sous hypothèse d'indépendance for (i in (1:nbl)) { for (j in (1:nbc)) { valt[i,j] = soml[i]*somc[j]/tg } ; # fin pour sur j } ; # fin pour sur i cat("\nValeurs attendues et marges \n\n") print(valt,digits=2,right=TRUE,print.gap=3) # calcul des contributions signées cat("\nContributions signées \n") nbt <- nbl*nbc tc <- vector(length=nbt) vl <- vector(length=nbt) vc <- vector(length=nbt) ts <- vector(length=nbt) vo <- vector(length=nbt) vt <- vector(length=nbt) ch <- 0 ic <- 0 vchi <- 0 mtcr <- matrix(nrow=nbl+1,ncol=nbc+1) rownames(mtcr) <- rep(" ",nbl+1) colnames(mtcr) <- rep(" ",nbc+1) mtcr[1,1] <- "" for (j in (1:nbc)) { mtcr[1,j+1] <- paste(" ",surncarg(8,mo2[j])) } ; # fin pour sur j for (i in (1:nbl)) { mtcr[i+1,1] <- surncarg(10,mo1[i]) for (j in (1:nbc)) { x <- (tcr[i,j]-valt[i,j]) ctr <- x*x/valt[i,j] vchi <- vchi + ctr ch <- ch + ctr if (x>0) { sgn <- "+" } else { sgn <- "-" } fvc <- formatC(ctr,format="f",width=6,dig=3) mtcr[i+1,j+1] <- paste(sgn,fvc) ic <- ic + 1 tc[ ic ] <- ctr vl[ ic ] <- i vc[ ic ] <- j ts[ ic ] <- x vo[ ic ] <- tcr[i,j] vt[ ic ] <- valt[i,j] } ; # fin pour sur j } ; # fin pour sur i print(mtcr,digits=3,right=TRUE,print.gap=3,quote=FALSE) ddl <- (nbl-1)*(nbc-1) alpha <- 5 pval <- chisq.test( tcr, correct=TRUE)$p.value chi2m <- qchisq( 1 -alpha/100, ddl ) cat("\nValeur du chi-deux ",vchi,"\n") cat("\nLe chi-deux max (table) à 5 % est ",chi2m ) cat(" ; p-value ", pval) cat(" pour ", ddl," degrés de liberté.") cat("\n") # une petite phrase pour conclure le test cat("\n décision : au seuil de ",alpha,"%") if (vchi<=chi2m) { cat(" on ne peut pas rejeter l'hypothèse") } else { cat(" on peut rejeter l'hypothèse") } ; # fin de si cat("\n qu'il y a indépendance entre ces deux variables qualitatives.\n") cat("\n") # tri des contributions signées idc <- order( tc , decreasing=TRUE) # affichage trié des contributions cat("\nPlus fortes contributions avec signe de différence \n\n") act <- matrix(nrow=nbt,ncol=9) rownames(act) <- rep(" ",nbt) colnames(act) <- c("Signe",surncarg(9," Valeur"),surncarg(7,"Pct"), surncarg(10,"Mligne"),surncarg(10,"Mcolonne"),"Ligne","Colonne","Obs","Th") for (i in (1:nbt)) { j <- idc[i] x <- ts[ j ] if (x>0) { act[i,1] <- " + " } else { act[i,1] <- " - " } act[i,2] <- formatC(tc[j],format="f",width=8,dig=3) ct <- tc[ j ] act[i,3] <- paste(formatC(100.0*(ct/vchi),format="f",width=5,dig=2), "%") act[i,4] <- surncarg(10,mo1[ vl[ j ] ]) act[i,5] <- surncarg(10,mo2[ vc[ j ] ]) act[i,6] <- vl[ j ] act[i,7] <- vc[ j ] act[i,8] <- formatC( vo[j] ,format="d",width=5,dig=0) act[i,9] <- formatC( vt[j] ,format="f",width=6,dig=1) } ; # fin pour sur i print(act,quote=FALSE,right=TRUE,print.gap=3) ; cat("\n") return() } ; # fin de fonction chi2IndepTable ################################################################# chi2IndepTableFacteur <- function(fact1,fact2) { ################################################################# # on utilise chi2IndepTable tc <- table(fact1,fact2) m1 <- levels(fact1) m2 <- levels(fact2) chi2IndepTable(tc,m1,m2) } ; # fin de fonction chi2IndepTableFacteur ################################################################# fcomp <- function() { ################################################################# cat("\n Vous disposez de deux fonctions pour comparer les moyennes : \n") cat("\n compMoyData( titre,nomA, varA, nomB,varB ) ") cat("\n si vous disposez des données") cat("\n") cat("\n compMoyNoData(titre,nA,moyA,ectA,nB,moyB,ectB) ") cat("\n si vous n'avez que les résumés statistiques") cat("\n") cat("\n Pour comparer des pourcentages :") cat("\n") cat("\n compPourc(titre,ia,na,ib,nb) \n\n") } ; # fin de fonction compMoy ################################################################# compMoyData <- function( titre,nomA, varA, nomB,varB ) { ################################################################# if (missing(titre)) { cat(" syntaxe : compMoyData( titre,nomA, varA, nomB,varB )\n") cat(" exemple : compMoyData( \"AGE Elf vs AGE Titanic\",\"AGE Elf\", age_elf, \"AGE Titanic\",age_titanic )\n") } else { # modification au 23 avril 2004 : utilisation de variance estimée # et non pas variance exacte (pour suivre sas) vab <- c(varA,varB) nab <- length(vab) mab <- sum(vab)/nab vab <- (sum(vab*vab)/nab-mab*mab)*nab/(nab-1) sab <- sqrt(vab) cab <- round(100*sab/mab) wab <- vab/nab na <- length(varA) ma <- sum(varA)/na va <- (sum(varA*varA)/na-ma*ma)*na/(na-1) sa <- sqrt(va) ca <- round(100*sa/ma) wa <- va/na nb <- length(varB) mb <- sum(varB)/nb vb <- (sum(varB*varB)/nb-mb*mb)*nb/(nb-1) sb <- sqrt(vb) cb <- round(100*sb/mb) wb <- vb/nb nu <- abs(ma-mb) de <- wa+wb r <- sqrt(de) delta <- nu/r cat("\n COMPARAISON DE MOYENNES (valeurs fournies) : ",titre,"\n\n") ; cat("Variable NbVal Moyenne Variance Ecart-type Cdv\n") ; cat(nomA," ",formatC(na,format="d",width=9), formatC(ma,format="f",width=12,digits=3), formatC(va,format="f",width=12,digits=3), formatC(sa,format="f",width=12,digits=3), formatC(ca,format="d",width=9)," %\n") ; cat(nomB," ",formatC(nb,format="d",width=9), formatC(mb,format="f",width=12,digits=3), formatC(vb,format="f",width=12,digits=3), formatC(sb,format="f",width=12,digits=3), formatC(cb,format="d",width=9)," %\n") ; cat("Global",formatC(nab,format="d",width=9), formatC(mab,format="f",width=12,digits=3), formatC(vab,format="f",width=12,digits=3), formatC(sab,format="f",width=12,digits=3), formatC(cab,format="d",width=9)," %\n") ; cat("\n") tt <- t.test(varA,varB) ; cat(" différence réduite : ",formatC(delta,format="f",digits=4)," ; p-value ",tt$p.value,"\n\n") ; cat(" au seuil de 5 % soit 1.96, on ") if (delta<1.96) { cat("ne peut pas rejeter") } else { cat("peut rejeter") } ; # fin de si cat(" l'hypothèse d'égalité des moyennes.\n\n") ; cat(" En d'autres termes, ") if (delta<1.96) { cat("il n'y a pas de") } else { cat("il y a une") } ; # fin de si cat(" différence significative entre les moyennes au seuil de 5 %.\n") cat("\n Voici ce qu'affiche la fonction t.test de R :\n" ) ; print(tt) ; cat("\n") ; cat("A l'aide d'anova, on obtient \n") valeurs <- c(varA,varB) groupes <- rep( c(1,2) , c(length(varA),length(varB)) ) print (anova(lm( valeurs ~ groupes ))) } # fin de si cat("\n") ; } ; # fin de fonction compMoyData ################################################################# compMoyNoData <- function(titre,na,ma,sa,nb,mb,sb) { ################################################################# if (missing(titre)) { cat(" syntaxe : compMoyNoData( titre,na,ma,sa,nb,mb,sb )\n") } else { ca <- round(100*sa/ma) va <- sa*sa wa <- va/na cb <- round(100*sb/mb) vb <- sb*sb wb <- vb/nb nu <- abs(ma-mb) de <- wa+wb r <- sqrt(de) delta <- nu/r cat("\n COMPARAISON DE MOYENNES (valeurs non fournies) ",titre,"\n\n") ; cat(" Variable nbVal Moyenne Variance Ecart-type Cdv\n") ; cat(" A ",formatC(na,format="d",width=9), formatC(ma,format="f",width=12,digits=3), formatC(va,format="f",width=12,digits=3), formatC(sa,format="f",width=12,digits=3), formatC(ca,format="d",width=9)," %\n") ; cat(" B ",formatC(nb,format="d",width=9), formatC(mb,format="f",width=12,digits=3), formatC(vb,format="f",width=12,digits=3), formatC(sb,format="f",width=12,digits=3), formatC(cb,format="d",width=9)," %\n") ; cat("\n") cat(" différence réduite : ",formatC(delta,format="f",digits=4),"\n\n") ; cat(" au seuil de 5 % soit 1.96, on peut ") if (delta<1.96) { cat("accepter") } else { cat("refuser") } ; # fin de si cat(" l'hypothèse d'égalité des moyennes.\n\n") ; cat(" En d'autres termes, ") if (delta<1.96) { cat("il n'y a pas de") } else { cat("il y a une") } ; # fin de si cat(" différence significative entre les moyennes au seuil de 5 %.\n") cat("\n") cat(" Vous pourriez utiliser à titre informatif\n\n") cat(" compMoyData(\"",titre,"\", simule(",ma,",",sa,",",na,"), simule(",mb,",",sb,",",nb,") ) \n") } # fin de si cat("\n") } ; # fin de fonction compMoyNoData ################################################################# compPourc <- function(titre,ia,na,ib,nb) { ################################################################# if (missing(titre)) { cat(" syntaxe : compPourc( titre,ia,na,ib,nb ) \n") } else { pa <- ia / na ; pb <- ib / nb ; p <- (ia+ib)/(na+nb) dp <- pa - pb df <- abs(dp) q <- p*(1-p)*(1/na+1/nb) r <- 1 eps <- 0 r <- sqrt(q) eps <- df/r rtest <- prop.test(c(ia,ib),c(na,nb)) pval <- rtest$p.value cat("\n COMPARAISON DE POURCENTAGES ",titre,"\n\n") ; cat(" population A, ",formatC(ia,width=5)," individus marqués sur ",formatC(na,format="d",width=7), " soit une proportion de ",formatC(100.0*pa,format="f",digits=5)," % \n") cat(" population B, ",formatC(ib,width=5)," individus marqués sur ",formatC(nb,format="d",width=7), " soit une proportion de ",formatC(100.0*pb,format="f",digits=5)," % \n") cat(" globalisation, ",formatC(ia+ib,width=5)," individus marqués sur ",formatC(na+nb,format="d",width=7), " soit une proportion de ",formatC(100.0*p,format="f",digits=5)," % \n") cat("\n") ; cat(" écart-réduit : ",formatC(eps,format="f",digits=4)," ; ") ; cat("\"p-value\" associée : ",pval,"\n\n") ; cat(" au seuil de 5 % soit 1.96, on peut ") if (eps<1.96) { cat("accepter") } else { cat("refuser") } ; # fin de si cat(" l'hypothèse d'égalité des pourcentages.\n\n") ; cat(" En d'autres termes, ") if (eps<1.96) { cat("il n'y a pas de") } else { cat("il y a une") } ; # fin de si cat(" différence significative entre les pourcentages au seuil de 5 %.\n\n") cat(" L'instruction R associée est \n\n prop.test( c(",ia,",",ib,") , c(",na,",",nb,") )\n\n") } # fin de si cat("\n") } ; # fin de fonction compPourc ################################################################# ################################################################# ## ## ## ghf FONCTIONS DE LECTURE DE FICHIERS ET DE VARIABLES ## ## ## ################################################################# ################################################################# dims <- function(df) { # renvoie une chaine qui donne le nombre de lignes et de colonnes return(paste(dim(df),collapse=" x ")) } ; # fin de fonction dims ################################################################# lit <- function() { ################################################################# # # fonction générale de présentation des fonctions de lecture et # et d'écriture de fichiers de données # cat("\n") cat("Pour la lecture et l'écriture des fichiers, vous pouvez utiliser :\n\n") cat(" lit.dbf( fichier .DBF ) pour Dbase\n") cat(" lit.dac( base des noms ) avec nom de lignes et de colonnes \n") cat(" lit.dar( fichier .DAR ) avec nom de lignes et de colonnes \n") cat(" lit.dar.wd( fichier .DAR ) lecture sur le site forge/~gh \n") cat(" lit.dat( fichier .DAT ) avec nom de lignes seulement \n") cat(" lit.texte( fichier .TXT ) lit tout un texte \n") cat(" lit.xls( fichier .XLS ) pour Excel [via le package gdata] \n") catn() ; cat(" df2csv( dataframe , nomfichier ) produit un .csv (pour Excel) \n") cat(" df2dac( listeDac , nomfichier ) produit les fichiers .ngr, .gal et .dac \n") cat(" ecrit.dar( dataframe , nomfichier ) avec nom de lignes et de colonnes \n") cat(" ecrit.dac( listeDac , nomfichier ) produit les fichiers .ngr, .gal et .dac \n") cat(" ecrit.df( dataframe, nomfichier ) avec nom de lignes et de colonnes \n") cat(" ecrit.xls( dataframe, nomfichier ) produit un .csv (pour Excel) \n") cat(" xls2dar( fichier .XLS) conversion .XLS ==> .DAR \n") cat("\n") } ; # fin de fonction lit ################################################################# lit.dbf <- function(dbf.name) { ################################################################# # # fonction copiée par (gH) avec l'autorisation de son auteur # pour lire un fichier Dbase # #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Shapefile Format - Read/Write shapefile format within R #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Ben Stabler benjamin.stabler@odot.state.or.us # Copyright (C) 2003 Oregon Department of Transportation #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Read DBF format #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ################################################################# infile<-file(dbf.name,"rb") # Header file.version <- readBin(infile,integer(), 1, size=1, endian="little") file.year <- readBin(infile,integer(), 1, size=1, endian="little") file.month <- readBin(infile,integer(), 1, size=1, endian="little") file.day <- readBin(infile,integer(), 1, size=1, endian="little") num.records <- readBin(infile,integer(), 1, size=4, endian="little") header.length <- readBin(infile,integer(), 1, size=2, endian="little") record.length <- readBin(infile,integer(), 1, size=2, endian="little") file.temp <- readBin(infile,integer(), 20, size=1, endian="little") header <- list(file.version,file.year, file.month, file.day, num.records, header.length, record.length) names(header) <- c("file.version","file.year","file.month","file.day","num.records","header.length","record.length") rm(file.version,file.year, file.month, file.day, num.records, header.length, record.length) # Calculate the number of fields num.fields <- (header$header.length-32-1)/32 field.name <- NULL field.type <- NULL field.length <- NULL field.decimal <- NULL # Field Descriptions (32 bytes each) for (i in 1:num.fields) { field.name.test <- readBin(infile,character(), 1, size=10, endian="little") field.name <- c(field.name,field.name.test) if (nchar(field.name.test)!=10) { file.temp <- readBin(infile,integer(), 10-(nchar(field.name.test)), 1, endian="little") } # fin de si field.type <- c(field.type,readChar(infile, 1)) file.temp <- readBin(infile,integer(), 4, 1, endian="little") field.length <- c(field.length,readBin(infile,integer(), 1, 1, endian="little")) field.decimal <- c(field.decimal, readBin(infile,integer(), 1, 1, endian="little")) file.temp <- readBin(infile,integer(), 14, 1, endian="little") } # fin de pour i # Create a table of the field info fields <- data.frame(NAME=field.name,TYPE=field.type,LENGTH=field.length,DECIMAL=field.decimal) # Set all fields with length<0 equal to correct number of characters fields$LENGTH[fields$LENGTH<0]<-(256+fields$LENGTH[fields$LENGTH<0]) # Read in end of attribute descriptions terminator - should be integer value 13 file.temp <- readBin(infile,integer(), 1, 1, endian="little") # Increase the length of field 1 by one to account for the space at the beginning of each record fields$LENGTH[1]<-fields$LENGTH[1]+1 # Add fields to the header list header <- c(header,fields=NULL) header$fields <- fields # Read in each record to a list element all.records <- list() for (i in 1:header$num.records) { all.records <- c(all.records, list(readChar(infile, header$record.length))) } # fin de pour i # Close the dbf file connection close(infile) # Funktion to split the strings and replace all " " with "" at the end of string format.record <- function(record) { record <- substring(record, c(1,cumsum(fields$LENGTH)[1:length(cumsum(fields$LENGTH))-1]+1),cumsum(fields$LENGTH)) record <- gsub(" +$","", record) record } # fin de fonction format.record # Split each record into columns and save as data.frame dbf <- data.frame(t(data.frame(lapply(all.records, format.record)))) rm(all.records) dimnames(dbf) <- list(1:header$num.records, header$fields$NAME) # Set the numeric fields to numeric for (i in 1:ncol(dbf)) { if(fields$TYPE[i]=="C") { dbf[[i]] <- as.character(dbf[[i]]) } if(fields$TYPE[i]=="N") { dbf[[i]] <- as.numeric(as.character(dbf[[i]])) } if(fields$TYPE[i]=="F") { d bf[[i]] <- as.numeric(as.character(dbf[[i]])) warning("Possible trouble converting numeric field in the DBF\n") } # fin de si type F } # fin de pour i # If the first field is of type character then remove the first # character of each record since the DBF stores a space for a # valid record and an * for a deleted record. # If the field is numeric then R removes the white space if(fields[1,2]=="C") { dbf[[1]] <- gsub("^[ *]", "", as.character(dbf[[1]])) } colnames(dbf) <- as.character(fields$NAME) colnames(dbf) <- gsub("_",".",colnames(dbf)) # Return the dbf as a list with a data.frame and a header list list(dbf=dbf, header=header) } # fin de fonction lit.dbf ################################################################# lit.dar <- function( nomfic,encode=NA ) { ################################################################# # # cette fonction traite la première ligne du fichier comme le nom # des colonnes et ensuite la première colonne de chaque ligne # comme le nom des lignes # if (is.na(encode)) { read.table(nomfic,head=TRUE,row.names=1,as.is=TRUE) } else { read.table(nomfic,head=TRUE,row.names=1,encoding=encode,as.is=TRUE) } # finsi } ; # fin de fonction lit.dar ################################################################# lit.dar.lh <- function( nomfic ) { ################################################################# # # lecture sur le site gh de localhost, répertoire Datasets # nomficweb <- paste("http://localhost/~gh/Datasets/",nomfic,sep="") read.table(nomficweb,head=TRUE,row.names=1,encoding="latin1") } ; # fin de fonction lit.dar.lh ################################################################# lit.dar.wd <- function( nomfic ) { ################################################################# # # lecture sur le site gh, répertoire Datasets # nomficweb <- paste("http://forge.info.univ-angers.fr/~gh/Datasets/",nomfic,sep="") read.table(nomficweb,head=TRUE,row.names=1,encoding="latin1") } ; # fin de fonction lit.dar.wd ################################################################# lit.dat <- function( nomfic,... ) { ################################################################# # # cette fonction lit un fichier de données # la première valeur de chaque ligne devient le nom de la ligne # la première ligne contient des données, ce n'est pas le nom des colonnes read.table(nomfic,head=FALSE,row.names=1,...) } ; # fin de fonction lit.dat ################################################################# lit.xls <- function( nomfic,... ) { ################################################################# # # lecture d'un fichier Excel library(gdata) dfxls <- read.xls( nomfic ) return( dfxls ) } ; # fin de fonction lit.xls ################################################################# lit.dac <- function(nombase) { ################################################################# if (missing(nombase)) { cat(" syntaxe : lit.dac( nom_fichier ) \n") cat(" cette fonction renvoie une liste dont les composantes $nomgrp, $grps et $dac \n") cat(" donnent respectivement les noms des groupes, les numéros de groupes et les données ;\n") cat(" la composante $basename contient la base du nom des fichiers à utiliser.\n ") return() } # fin si # préparation des noms de fichier cat(" Base des noms de fichier : ",nombase,"\n") fngr <- paste(nombase,".ngr",sep="") fgal <- paste(nombase,".gal",sep="") fdac <- paste(nombase,".dac",sep="") ngrp <- read.table(fngr,as.is=TRUE) nomgrp <- ngrp[,2] cat(" ",length(nomgrp)," noms de groupes lus dans ",fngr,"\n") cols <- read.table(fgal,as.is=TRUE) nomcol <- cols[,2] cat(" ",length(nomcol)," noms de colonnes lus dans ",fgal,"\n") dac <- read.table(fdac,row.names=1) grps <- dac[,1] dac <- dac[,-1] colnames(dac) <- nomcol cat(" ",dim(dac)[1]," lignes et ",dim(dac)[2],"colonnes dans ",fdac,"\n") return( list(nomgrp=nomgrp,grps=grps,dac=dac,basename=nombase) ) } # fin de fonction lit.dac ################################################################# lit.texte <- function(fn,...) { ################################################################# # lit tout un texte et le renvoie sous forme d'une chaine de caractères if (missing(fn)) { cat(" syntaxe : txt <- lit.texte(nom_de_fichier) \n") cat(" renvoie une variable chaine de caractères qui contient tout le texte ;\n") cat(" on peut ensuite l'analyser avec analexies(txt).\n") return() } # fin si if (!file.exists(fn)) { cat("désolé, le fichier ",fn," n'existe pas.\n") return() } # fin si ftxt <- readLines(fn,n=-1,...) leTxt <- "" for (lig in ftxt) { leTxt <- paste(leTxt,lig) } # fin pour return(leTxt) } # fin de fonction lit.texte ################################################################# ecrit.df <- function( df , nomfic ) { ################################################################# # # cette fonction écrit un "dataframe" avec comme première ligne du fichier comme le nom # des colonnes et ensuite la première colonne de chaque ligne # est le nom des lignes # #write.table(df,nomfic,quote=FALSE) options(width=2048) ; options(max.print=123456) ; sink(nomfic) print(df,row.names=FALSE) sink() cat("en principe, vous pouvez utiliser le fichier ",nomfic,"\n\n") cat(" mais n'oubliez pas de vérifier la fin du fichier.\n") cat("\n en cas de problème : sortir de R, retourner dans R et \n") cat(" utiliser \n") cat(" options(max.print=123456) \n") cat(" options(width=2048) \n") cat("avant de relancer ecrit.dar\n") ; } ; # fin de fonction ecrit.df ################################################################# ecrit.dar <- function( df , nomfic ) { ################################################################# # un simple alias pour ecrit.df ecrit.df( df , nomfic ) } ; # fin de fonction ecrit.dar ################################################################# df2csv <- function( df , nomfic ) { ################################################################# # # un simple alias pour write.csv if (missing(nomfic)) { cat("d2csv : écrit un data frame en fichier .csv \n") ; cat("syntaxe : df2csv(df,nomfic) \n") cat("exemple : df2csv(elf,\"elf.csv\") \n\n") return() ; } ; # fin de si #nf <- paste(nomfic,".csv",sep="") write.csv(x=df,file=nomfic) cat("vous pouvez consulter ",nomfic,"\n") } ; # fin de fonction df2csv ################################################################# ecrit.csv <- function( df , nomfic ) { ################################################################# # # un simple alias pour df2.csv df2csv( df , nomfic ) } ; # fin de fonction ecrit.csv ################################################################# ecrit.xls <- function( df , nomfic ) { ################################################################# # # un simple alias pour df2.csv df2csv( df , nomfic ) } ; # fin de fonction ecrit.xls ################################################################# xls2dar <- function( nomficxls ) { ################################################################# # # convertit un fichier Excel en un fichier .DAR if (missing(nomficxls)) { cat("xls2dar : convertit un fichier .xls en un fichier texte .dar avec noms des colonnes \n") ; cat("syntaxe : xls2dar(fichierExcel) \n") cat("exemple : xls2dar(\"elf.xls\") \n\n") return() ; } ; # fin de si library(gdata) df <- read.xls( nomficxls ) row.names(df) <- df[,1] df <- df[,(-1)] nomdar <- paste(nombase(nomficxls),".dar",sep="") ecrit.dar(df,nomdar) } ; # fin de fonction xls2dar ################################################################# df2dac <- function(df,nombase) { ################################################################# if (missing(nombase)) { cat("df2dac : produit les fichiers .gal .ngr et .dac à partir d'un jeu de données adapté\n") ; cat("syntaxe : df2dac(df,nombase) \n") cat("exemple : df2dac(binary,\"demo\") \n\n") return() ; } ; # fin de si # préparation des noms de fichier cat(" Base des noms de fichier : ",nombase,"\n") fngr <- paste(nombase,".ngr",sep="") fgal <- paste(nombase,".gal",sep="") fdac <- paste(nombase,".dac",sep="") # écriture des fichiers numgrp <- 1:length(df$nomgrp) write.table(x=cbind(numgrp,df$nomgrp),file=fngr,quote=FALSE,row.names=FALSE,col.names=FALSE) numcol <- 1:ncol(df$dac) write.table(x=cbind(numcol,colnames(df$dac)),file=fgal,quote=FALSE,row.names=FALSE,col.names=FALSE) write.table(x=cbind(df$grps,df$dac),file=fdac,quote=FALSE,row.names=TRUE,col.names=FALSE) cat("en principe, vous pouvez utiliser les fichiers ",fngr,", ",fgal," et ",fdac,"\n\n",sep="") } ; # fin de fonction df2dac ################################################################# ecrit.dac <- function(df, nombase ) { ################################################################# # un alias pour df2dac df2dac(df,nombase) } ; # fin de fonction ecrit.dac ################################################################# nombase <- function( nomfic ) { ################################################################# # # on récupère le nom du fichier (partie avant le point) # tabstr <- strsplit(nomfic,"\\.") return( unlist(tabstr)[1]) } ; # fin de fonction nombase ################################################################# ################################################################# ################################################################# ## ## ## ghf AUTRES FONCTIONS ## ## ## ################################################################# ################################################################# ################################################################# print10 <- function( matd ) { ################################################################# # # affiche les 10 premières de la matrice des données # nbl <- dim(matd)[1] dix <- 10 if (nbl>dix) { lemsg <- paste("Voici les 10 premières lignes de données (il y en a ",nbl," en tout)",sep="") } else { lemsg <- paste("Voici l'ensemble des ",nbl," lignes de données",sep="") dix <- nbl } ; # fin de si catln(lemsg) print(matd[(1:dix),]) } ; # fin de fonction read.dar ################################################################# litcol <- function(fichier,numCol,entete=TRUE) { ################################################################# mydata <- read.table(fichier,head=entete) vdata <- mydata[,numCol] cat(" vous disposez de ",length(vdata)," valeurs \n") return( vdata ) } ; # fin de fonction litcol ################################################################# ## FONCTIONS SUR CHAINES DE CARACTERES ################################################################# catln <- function( x) { ################################################################# # affiche x suivi d'un saut de ligne cat(x,"\n") } ; # fin de fonction catln ################################################################# surncarg <- function( long,chen ) { ################################################################# # # renvoie la chaine "chen" sur "long" caractères # sans tronquer ni déborder # newchen <- chen while (nchar(newchen)<long) { newchen <- paste(newchen," ",sep="") } return(newchen) } ; # fin de fonction surncarg ################################################################# ghtrim <- function( chen ) { ################################################################# # # enlève les blancs de tete et de queue # chenOrg <- chen while (substr(chen,1,1)==" ") { chen <- substr(chen,2,nchar(chen)) } dp <- nchar(chen) while (substr(chen,dp,dp)==" ") { chen <- substr(chen,1,dp-1) dp <- nchar(chen) } ; # fin de tant que return( chen ) } ; # fin de ghtrim ################################################################# chaineEnVectNum <- function(x) { as.numeric(unlist(strsplit(x," +",perl=TRUE))) } ; # fin de fonction chaineEnVectNum ################################################################# chaineEnListe <- function( chen ) { ################################################################# # # convertit une chaine de caractères comme strsplit(...," ") # après avoir enlevé les espaces multiples newchen <- "" chen <- ghtrim(chen) lngchen <- nchar(chen) for (idc in 1:lngchen) { cac <- substr(chen,idc,idc) cas <- "." if (idc<lngchen) { cas <- substr(chen,idc+1,idc+1) } cac2 <- paste(cac,cas,sep="") if (cac2 != " ") { newchen <- paste(newchen,cac,sep="") } ; # fin de si } ; # fin pour idc return( unlist( strsplit(newchen," ") ) ) } ; # fin de fonction chaineEnListe ################################################################# col.names <- function( m ) { ################################################################# # pour être cohérent avec row.names return(colnames(m)) } ; # fin de fonction col.names ################################################################# vecteurEnChaine <- function( v ) { ################################################################# nbe <- length(v) pde <- 1:nbe ch <- "" for (ide in pde) { ch <- paste(ch, v[ide]) } # fin pour ide return(ghtrim(ch)) } ; # fin de fonction vecteurEnChaine ################################################################# colMins <- function( df ) { # minimum par colonne ################################################################# return( apply(X=df,MARGIN=2,FUN=min) ) } ; # fin de fonction colMins ################################################################# colMaxs <- function( df ) { # maximum par colonne ################################################################# return( apply(X=df,MARGIN=2,FUN=max) ) } ; # fin de fonction colMaxs ################################################################# colMedians <- function( df ) { # médiane par colonne ################################################################# return( apply(X=df,MARGIN=2,FUN=median) ) } ; # fin de fonction colMedians ################################################################# skku <- function( x ) { ################################################################# # # skewness et kurtosis, comme ils disent # cnt_x <- length(x) moy_x <- sum(x)/cnt_x med_x <- median(x) mct_x <- sum(x*x)/cnt_x var_x <- mct_x - moy_x**2 ect_x <- sqrt( var_x) dix <- (x-moy_x)/ect_x sk <- sum(dix**3)/cnt_x ku <- sum(dix**4)/cnt_x cat(" pour ",cnt_x," valeurs \n") cat(" moyenne ",moy_x,"\n") cat(" médiane ",med_x,"\n") cat(" écart-type ",ect_x,"\n") cat(" skewness ",sk ,"\n") cat(" kurtosis ",ku ,"\n") } ; # fin de fonction skku ################################################################# simule <- function(moy_s,ect_s,nb_val) { ################################################################# if (missing(moy_s)) { cat(" syntaxe : simule(moyenne,écart-type,nombre de valeurs) \n") } else { # utilisation naive de rnorm xdata <- rnorm(nb_val,moy_s,ect_s) prec <- 10**(-6) # correction de la moyenne lmdif <- mean(xdata) - moy_s netap <- 1 while ((abs(lmdif)>prec) && (netap<20)) { netap <- netap + 1 xdata <- xdata - lmdif lmdif <- mean(xdata) - moy_s } ; # fin de tant que ledif <- ect(xdata) - ect_s # correction de l'écart-type vpc <- 1 ntour <- 1 ledif <- ect(xdata) - ect_s xdata <- sort(xdata) while ((abs(ledif)>prec) && (ntour<2000)) { netap <- 1 idvam <- 1 xdata <- sort(xdata) ledif <- ect(xdata) - ect_s while ((abs(ledif)>prec) && (netap<2000)) { netap <- netap + 1 if ((xdata[idvam]>moy_s) && (ledif>0)) { xdata[idvam] <- xdata[idvam] - ledif/vpc sens <- 1 } else { xdata[idvam] <- xdata[idvam] + ledif/vpc sens <- 0 } # fin de si jdvam <- nb_val + 1 - idvam if (sens==0) { xdata[jdvam] <- xdata[jdvam] - ledif/vpc } else { xdata[jdvam] <- xdata[jdvam] + ledif/vpc } # fin de si idvam <- idvam + 1 if (idvam>nb_val) { idvam <- 1 } ledif <- ect(xdata) - ect_s } ; # fin de tant que ntour <- ntour + 1 } ; # fin de tant que return(xdata) } # fin si cat("\n") } # fin de fonction simule ################################################################# allqtdbf <- function(nomdbf,unites="???") { # exemples : # allqtdbf("vins",unites) # allqtdbf("vins","hl") # allqtdbf("vins") # allqtdbf("chu825qt") # allqtdbf("chu825qt",chaineEnListe("G/l UI/l mmo/l mug/l % mg/dl an")) nomficdbf <- paste(nomdbf,".dbf",sep="") data <- read.dbf(nomficdbf)$dbf data <- data[,-1] nomcol <- colnames(data) if (length(unites)==1) { unites <- rep(unites,length(nomcol)) } # fin de si allQT(data,nomcol,unites) } # fin de fonction allqtdbf ################################################################# col2fact <- function(tdd) { ################################################################# # transforme des colonnes en facteur # par exemple 10 15 30 # 20 21 19 # devient 10 1 # 20 1 # 15 2 # 21 2 # 30 3 # 19 3 dd <- dim(tdd) nblig <- dd[1] nbcol <- dd[2] nblc <- nblig*nbcol mr <- matrix(nrow=nblc,ncol=2) idl <- 0 for (idc in 1:nbcol) { deb <- (idc-1)*nblig + 1 fin <- deb + nblig - 1 plg <- deb:fin mr[plg,1] <- tdd[,idc] mr[plg,2] <- idc } ; # fin pour idc return( mr) } # fin de fonction col2fact ################################################################# bestValAssoc <- function(x,y) { if (y>0.5) { return(x) } else { return(1-x) } } # fin de fonction bestValAssoc ################################################################# ################################################################# identif <- function(nomv,vec,mat,affiche=1) { ################################################################# if (affiche==1) { cat("\nIDENTIFICATION PROBABILISTE\n\n") } nbl <- dim(mat)[1] nbc <- dim(mat)[2] if (affiche==1) { cat("Vecteur\n") print( vec ) cat("Matrice\n") print( mat ) } # fin si vpa <- vector(length=nbl) fpa <- vector(length=nbl) rpa <- vector(length=nbl) cvm <- vector(length=nbl) pvm <- vector(length=nbl) for (idl in (1:nbl)) { p1 <- 1 p2 <- 1 for (jdc in (1:nbc)) { x <- mat[idl,jdc] y <- vec[jdc] p1 <- p1*bestValAssoc(x,y) p2 <- p2*bestValAssoc(x,x) } ; # fin pour jdc vpa[idl] <- p1 cvm[idl] <- p2 } ; # fin pour idl vpa <- round( vpa , 4 ) fpa <- round( 100*vpa/sum(vpa) , 2 ) rpa <- round( 100*vpa/max(vpa) , 2 ) pvm <- round( 100*vpa/cvm , 2 ) matres <- cbind(vpa,fpa,rpa,cvm,pvm) row.names(matres) <- row.names(mat) if (affiche==1) { cat("\nRésultats par groupe\n") print(matres) cat("\n") } # fin si # gestion des résultats pour tests sur groupes connus tauxMs <- 80 tauxVm <- 80 de <- 0 ms <- 0 is <- 0 vm <- 0 for (idl in (1:nbl)) { if (fpa[idl]>ms) { is <- idl ms <- fpa[idl] vm <- pvm[idl] } # fin si if (fpa[idl]>tauxMs) { de <- 1 if (affiche==1) { cat("Le vecteur semble appartenir au groupe ") cat(idl) cat(" soit ") cat(row.names(mat)[idl]) cat("\n") } # fin si if (pvm[idl]>tauxVm) { if (affiche==1) { cat("En fait, le vecteur appartient vraiment au groupe ") cat(idl) cat(" soit ") cat(row.names(mat)[idl]) cat(".\n") } # fin si } else { if (affiche==1) { cat("En fait, le vecteur n'appartient pas vraiment au groupe ") cat(idl) cat(" soit ") cat(row.names(mat)[idl]) cat(".\n") } # fin si } # fin si } # fin si } ; # fin pour idl ldr <- c(nomv,de,ms,vm,is) if (affiche==1) { cat("\nLigne résumée d'affectation\n") cat(ldr) cat("\n") } # fin si return(ldr) } # fin de fonction identif ################################################################# ################################################################# identifgc <- function(fdac,fmdp,fngr) { ################################################################# cat("\nVERIFICATION D'IDENTIFICATION PROBABILISTE SUR GROUPES CONNUS\n") dac <- read.table(fdac,row.names=1) mdp <- read.table(fmdp,row.names=1) ngr <- read.table(fngr) ngr <- ngr[,-1] grp <- dac[,1] mdac <- dac[,-1] nbl <- dim(mdac)[1] nbc <- dim(mdac)[2] colnames(mdac) <- 1:nbc colnames(mdp) <- 1:nbc cat("Colonnes\n") print(ngr) cat("Données binaires avec indication de groupe\n") print(dac) cat("Matrice des fréquences de positivité\n") print(mdp) matres <- matrix(nrow=nbl,ncol=9) row.names(matres) <- row.names(mdac) nb_de <- 0 nb_bc <- 0 nb_mc <- 0 for (idl in (1:nbl)) { nmvec <- row.names(mdac)[idl] levec <- mdac[idl,] lr <- identif(nmvec,levec,mdp,0) print(c(idl,lr)) matres[idl,1] <- lr[2] matres[idl,2] <- grp[idl] matres[idl,3] <- lr[5] matres[idl,4] <- lr[3] matres[idl,5] <- lr[4] nb_de <- nb_de + as.numeric(lr[2]) matres[idl,6] <- nb_de if (matres[idl,3]==grp[idl]) { vbc <- 1 nb_bc <- nb_bc + 1 } else { vbc <- 0 nb_mc <- nb_mc + 1 } # fin de si matres[idl,7] <- vbc matres[idl,8] <- nb_bc matres[idl,9] <- nb_mc } ; # fin pour idl print(matres) } # fin de fonction identifgc ################################################################# cdr <- function(vecteurQT) { return( cdrn(vecteurQT,min(vecteurQT),max(vecteurQT)) ) } ; # fin de fonction cdr cdrn <- function(vecteurQT,a,b) { nbv <- length(vecteurQT) rng <- b-a ect <- sd(vecteurQT) smax <- rng/2 rbiais <- nbv/(nbv-1) fcdrn <- ect/(sqrt(rbiais)*smax) ; return( fcdrn ) } ; # fin de fonction cdrn ################################################################# ################################################################# ic <- function() { ################################################################# # # rappel des diverses fonctions pour les intervalles de confiance # cat("\n Vous disposez de cinq fonctions pour les intervalles de confiance ") cat("\n et de deux fonctions pour les calculs de taille d'échantillons : \n") cat("\n icp \n") cat(" pour l'estimation par intervalle d'une proportion\n") cat(" syntaxe : icp(nbVal,pChap,nivConf=0.05,affichage=FALSE) \n") cat("\n icm \n") cat(" pour l'estimation par intervalle d'une moyenne sachant m et s\n") cat(" syntaxe : icm(nbVal,moyQt,ectQt,nivConf=0.05,affichage=FALSE) \n") cat("\n icmQT \n") cat(" pour l'estimation par intervalle de la moyenne d'une QT\n") cat(" syntaxe : icmQT(varQT,nivConf=0.05,affichage=FALSE) \n") cat(" (on peut aussi utiliser t.test(varQT) \n" ) ; cat("\n ice \n") cat(" pour l'estimation par intervalle de l'écart-type \n") cat(" syntaxe : ics(nbVal,ectQt,nivConf=0.05,echo=FALSE) \n") cat("\n iceQT \n") cat(" pour l'estimation par intervalle d'une écart-type d'une QT\n") cat(" syntaxe : icsQT(varQT,nivConf=0.05,echo=FALSE) \n") cat("\n tailleEchProp \n") cat(" pour la taille d'un échantillon en vue d'estimer une proportion\n") cat(" syntaxe : tailleEchProp(pChapeau,margeErreur,nivConf=0.05) \n") cat("\n") cat("\n tailleEchMoy \n") cat(" pour la taille d'un échantillon en vue d'estimer une moyenne\n") cat(" syntaxe : tailleEchMoy(ecartType,margeErreur,nivConf=0.05) \n") cat("\n") } ; # fin de fonction ic ################################################################# icp <- function(nbVal,pChap,nivConf=0.05,affichage=FALSE) { ################################################################# if (missing(nbVal)) { cat("icp : intervalle de confiance d'une proportion \n") cat("syntaxe : icp(nbVal,pChap,nivConf=0.05,affichage=FALSE) \n") cat("exemples : icp(580,0.262) \n") cat(" icp(580,0.262,0.05) \n") cat(" icp(580,0.262,0.05,TRUE) \n") return() } ; # fin de si alp <- nivConf/2; z <- qnorm(1-alp); f_z <- sprintf("%6.3f",z) ; nbValqnorm <- nbVal - 1 margeE <- z*sqrt(pChap*(1-pChap)/nbValqnorm) liminf <- pChap - margeE limsup <- pChap + margeE if (affichage) { cat(" Pour ",nbVal," valeurs et une proportion estimée p-chapeau ",pChap," au niveau ",nivConf,"\n") cat(" la valeur critique issue de la loi normale est ",z," soit ",f_z,"\n") cat(" l'intervalle de confiance est donc sans doute [",liminf," ; ",limsup," ]\n ") cat(" soit, en arrondi, [ ",sprintf("%0.3f",liminf)," ; ",sprintf("%0.3f",limsup)," ]\n ") } # fin de si return(c(liminf,limsup)) } ; # fin de fonction icm ################################################################# icm <- function(nbVal,moyQt,ectQt,nivConf=0.05,affichage=FALSE) { ################################################################# if (missing(nbVal)) { cat("icm : intervalle de confiance d'une moyenne \n") ; cat("syntaxe : icm(nbVal,moyQt,ectQt,nivConf=0.05,echo=FALSE) \n") cat("exemples : icm(50,25.03,1.341641) \n") cat(" icm(50,25.03,1.341641,0.01) \n") cat(" icm(50,25.03,1.341641,0.01,TRUE) \n") return() ; } ; # fin de si ddl <- nbVal-1; alp <- nivConf/2; valt <- qt(alp,ddl,lower.tail=FALSE) f_t <- sprintf("%6.3f",valt) ; margeE <- valt*ectQt/sqrt(nbVal) liminf <- moyQt - margeE limsup <- moyQt + margeE if (affichage) { cat(" Pour ",nbVal," valeurs de moyenne ",moyQt," et d'écart-type ",ectQt," au niveau ",nivConf,"\n") cat(" la valeur critique issue de la loi du t de Student pour ",ddl," ddl est ",valt," soit ",f_t,"\n") cat(" l'intervalle de confiance est donc sans doute [",liminf," ; ",limsup," ]\n ") cat(" soit, en arrondi, [ ",sprintf("%0.3f",liminf)," ; ",sprintf("%0.3f",limsup)," ]\n ") } # fin de si return(c(liminf,limsup)) } ; # fin de fonction icm ################################################################# icmQT <- function(varQT,nivConf=0.05,affichage=FALSE) { ################################################################# if (missing(varQT)) { cat("icmQT : intervalle de confiance d'une moyenne sachant ses valeurs\n") ; cat("syntaxe : icmQT(varQT,nivConf=0.05,echo=FALSE) \n") cat("exemples : icmQT(lng) \n") cat(" icmQT(AGE_ELF,0.01) \n") return() ; } ; # fin de si n <- length(varQT) m <- mean(varQT) s <- sd(varQT) return( icm(n,m,s,nivConf,affichage) ) } ; # fin de fonction icmQT ################################################################# ice <- function(nbVal,ectQt,nivConf=0.05,affichage=FALSE) { ################################################################# if (missing(nbVal)) { cat("ice : intervalle de confiance d'un écart-type \n") ; cat("syntaxe : ice(nbVal,ectQt,nivConf=0.05,echo=FALSE) \n") ; cat("exemples : ice(5,3.676955) \n") ; cat(" ice(5,3.676955,0.05) \n") ; cat(" ice(5,3.676955,0.01,TRUE) \n") ; return() ; } ; # fin de si s <- ectQt ddl <- nbVal-1 alpr <- nivConf/2 chir <- qchisq(alpr,ddl,lower.tail=FALSE) f_chir <- sprintf("%6.3f",chir) alpl <- 1-nivConf/2 chil <- qchisq(alpl,ddl,lower.tail=FALSE) f_chil <- sprintf("%6.3f",chil) liminf <- sqrt(ddl*s*s/chir) limsup <- sqrt(ddl*s*s/chil) if (affichage) { cat(" Pour ",nbVal," valeurs d'écart-type ",ectQt," au niveau ",nivConf,"\n") cat(" la valeur critique gauche issue de la loi du chi2 est ",chir," soit ",f_chir,"\n") cat(" la valeur critique droite issue de la loi du chi2 est ",chil," soit ",f_chil,"\n") cat(" l'intervalle de confiance est donc sans doute [",liminf," ; ",limsup," ]\n ") cat(" soit, en arrondi, [ ",sprintf("%0.3f",liminf)," ; ",sprintf("%0.3f",limsup)," ]\n ") } # fin de si return(c(liminf,limsup)) } ; # fin de fonction ice ################################################################# iceQT <- function(varQT,nivConf=0.05,affichage=FALSE) { ################################################################# n <- length(varQT) s <- sd(varQT) return( ice(n,s,nivConf,affichage) ) } ; # fin de fonction iceQT ################################################################# tailleEchProp <- function(pChapeau,margeErreur,nivConf=0.05) { ################################################################# if (missing(pChapeau)) { cat("tailleEchProp : taille d'Echantillon pour estimer une proportion\n") ; cat("syntaxe : tailleEchProp(pChapeau,margeErreur,nivConf=0.05) \n") cat("exemples : tailleEchProp(0.169,4) \n") cat(" tailleEchProp(0.169,4,0.10) \n") return() ; } ; # fin de si z <- qnorm(1-nivConf/2) f_z <- sprintf("%6.3f",z) cat(" la valeur critique issue de la loi normale est ",f_z,"\n") m <- margeErreur/100 n1 <- z*z*pChapeau*(1-pChapeau)/(m*m) n2 <- floor(n1) + 1 ; cat("La taille minimale requise est sans doute ",n1," qu'on arrondira certainement en ",n2,"\n\n") return(n2) } ; # fin de fonction tailleEchProp ################################################################# tailleEchMoy <- function(ecartType,margeErreur,nivConf=0.05) { ################################################################# if (missing(ecartType)) { cat("tailleEchProp : taille d'Echantillon pour estimer une moyenne\n") ; cat("syntaxe : tailleEchMoy(ecartType,margeErreur,nivConf=0.05) \n") cat("exemples : tailleEchMoy(0.64,0.25) \n") cat(" tailleEchMoy(0.64,0.25,0.10) \n") return() ; } ; # fin de si z <- qnorm(1-nivConf/2) f_z <- sprintf("%6.3f",z) cat(" la valeur critique issue de la loi normale est ",f_z,"\n") m <- margeErreur/100 rn <- z*ecartType/margeErreur n1 <- rn*rn n2 <- floor(n1) + 1 ; cat("La taille minimale requise est sans doute ",n1," qu'on arrondira certainement en ",n2,"\n\n") return(n2) } ; # fin de fonction tailleEchMoy ################################################################# numeroteId <- function(df) { ################################################################# nbl <- dim(df)[1] ids <- matrix(nrow=nbl,ncol=1) for (idl in (1:nbl)) { ids[idl,1] <- paste("I",sprintf("%04d",idl),sep="") } # fin pour idl ndf <- as.data.frame(cbind(ids,df)) colnames(ndf) <- c("Iden",colnames(df)) return(ndf) } ; # fin de fonction numeroteId ################################################################# datagh <- function(dossier) { ################################################################# if (missing(dossier)) { # on prépare la liste des dossiers idossier <- 0 nbdossier <- 7 matdossier <- matrix(nrow=nbdossier,ncol=5) colnames(matdossier) <- c(surncarg(8,"Dossier"),"individus","variables","QT","QL") rownames(matdossier) <- 1:nbdossier idossier <- idossier + 1 matdossier[idossier,1] <- surncarg(8,"ELF") matdossier[idossier,(2:5)] <- c(99,7,1,5) #idossier <- idossier + 1 #matdossier[idossier,1] <- surncarg(8,"PBIO") #matdossier[idossier,(2:5)] <- c(419,12,0,12) #idossier <- idossier + 1 #matdossier[idossier,1] <- surncarg(8,"CETOP") #matdossier[idossier,(2:5)] <- c(246,122,0,0) idossier <- idossier + 1 matdossier[idossier,1] <- surncarg(8,"TITANIC") matdossier[idossier,(2:5)] <- c(2201,5,0,5) idossier <- idossier + 1 matdossier[idossier,1] <- surncarg(8,"VINS") matdossier[idossier,(2:5)] <- c(18,8,8,0) idossier <- idossier + 1 matdossier[idossier,1] <- surncarg(8,"HER") matdossier[idossier,(2:5)] <- c(80,14,13,1) idossier <- idossier + 1 matdossier[idossier,1] <- surncarg(8,"LEA") matdossier[idossier,(2:5)] <- c(778,29,28,1) idossier <- idossier + 1 matdossier[idossier,1] <- surncarg(8,"IRIS") matdossier[idossier,(2:5)] <- c(150,5,4,1) idossier <- idossier + 1 matdossier[idossier,1] <- surncarg(8,"APPART") matdossier[idossier,(2:5)] <- c(28,4,2,0) # et on affiche cat("\n LISTE DES ",nbdossier,"DOSSIERS DISPONIBLES VIA datagh() \n\n") print(matdossier,right=TRUE,print.gap=3,quote=FALSE) cat("\n Pour utiliser un dossier, taper datagh(\"DOSSIER\") ; ") ; cat("\n où DOSSIER est le nom (en minuscules) du dossier ") ; cat("\n par exemple pour elf, taper datagh(\"elf\") ; \n\n") ; return(-1) } else { dossier <- tolower(dossier) lieu1 <- "http://forge.info.univ-angers.fr/~gh/Datasets" lieu2 <- "/home/infoleria/gh/public_html/Datasets" lieu3 <- "/home/gh/public_html/Datasets" lieux <- c(lieu1,lieu2,lieu3,".","K:/Stat_ad","~/Crs/Stat/Data","I:/Crs/Stat/Data") # on cherche les données nomfic <- paste(dossier,".dar",sep="") nomdsc <- paste(dossier,".dsc",sep="") idl <- 1 vu <- 0 nbl <- length(lieux) while (idl<=nbl) { nf <- paste(lieux[idl],nomfic,sep="/") #cat(" on cherche le fichier ",nf,"\n") if (idl==1) { library(RCurl) fc <- url.exists(nf) } else { fc <- file.exists(nf) } # fin si if (fc) { # le fichier est vu cat("\n DOSSIER ",dossier) cat(" (après lecture de ",nf,") :\n") lien <- paste("http://forge.info.univ-angers.fr/~gh/Datasets/",dossier,".htm",sep="") cat(" DESCRIPTIF : ",lien,"\n") idl <- nbl + 1 vu <- 1 # récupération de la matrice des données matdata <- lit.dar(nf,encode="latin1") } else { #cat(" fichier ",nf,"non vu\n\n") } ; # fin de si fc ==0 idl <- idl + 1 } ; # fin de tant que sur idl if (vu==0) { cat("\n dossier ",sQuote(dossier)," non vu...\n") } else { # on cherche le descriptif des données src1 <- "http://forge.info.univ-angers.fr/~gh/Datasets" src2 <- "http://forge.info.univ-angers.fr/~gh/" src3 <- "/home/gh/Bin" src4 <- "/home/info/gh/Bin/" src5 <- "/home/gh/public_html/Datasets" src6 <- "/home/gh/public_html/Datasets" srcs <- c(src1,src2,src3,src4,src5,src6,".","X:/","K:/Stat_ad","~/Crs/Stat/Data","I:/Crs/Stat/Data") nds <- "datagh.r" jdl <- 1 wu <- 0 nbs <- length(srcs) while (jdl<=nbs) { #ndf <- paste(srcs[jdl],nds,sep="/") ndf <- paste(srcs[jdl],nds,sep="/") #cat("on veut lire ",ndf,"\n") if (jdl<=2) { library(RCurl) gc <- url.exists(ndf) } else { gc <- file.exists(ndf) } # fin si if (gc) { # le fichier est vu jdl <- nbs + 1 wu <- 1 source(ndf,encoding="latin1") # et on exécute la fonction liée au dossier fdossier <- paste("datagh_",dossier,sep="") ghcmd <- call(fdossier,matdata) #cat(" gh cmd est : ",ghcmd,"\n") eval(ghcmd) # pour elf cela serait datagh_elf(matdata) } ; # fin de si gc ==0 jdl <- jdl + 1 } ; # fin de tant que sur idl if (wu==0) { cat("\n dossier ",sQuote(dossier)," aucun descriptif vu...\n") } ; # fin de si pas vu } ; # fin de si pas vu } ; # finsi sur paramètre manquant } ; # fin de fonction datagh ################################################################# # # fonctions de "fainéant de la frappe au clavier" # ################################################################# dql <- function(vql,a=FALSE,b="") { ################################################################# # # un decritQL automatique tdql <- paste("tql <- t_",vql,sep="") mdql <- paste("m_",vql,sep="") decritQL(eval(tdql),eval(vql),eval(mdql),a,b) } # fin de fonction dql ################################################################# dqt <- function(vqt,a=FALSE,b="") { ################################################################# # # un decritQT automatique tdqt <- paste("tqt <- t_",vqt,sep="") udqt <- paste("u_",vqt,sep="") decritQT(eval(tdqt),eval(vqt),eval(udqt),a,b) } # fin de fonction dql ################################################################# scr <- function(n) { ################################################################# # # découpage de l'écran graphique if (n==1) { par (mfrow=c(1,1)) } if (n==2) { par (mfrow=c(1,2)) } if (n==4) { par (mfrow=c(2,2)) } } # fin de fonction scr ################################################################# sigcodes <- "Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 'NS' 1" ################################################################# as.sigcode <- function(pvalue) { ################################################################# # as.sigcode(p) pour mettre # Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 'NS' 1 retc <- " NS" pvalue <- as.numeric(pvalue) if (pvalue<=0.100) { retc <- " ." } if (pvalue<=0.050) { retc <- " *" } if (pvalue<=0.010) { retc <- " **" } if (pvalue<=0.001) { retc <- "***" } return(retc) } # fin de fonction as.sigcode ################################################################# sdmax <- function(n,a,b) { ################################################################# # renvoie l'écart-type maximal de n points sur [a,b] lesval <- c(rep(a,n/2),rep(b,n/2)) if ((n%%2)==1) { lesval <- c(a,lesval) ; } ; # n impair return(sd(lesval)) } # fin de fonction sdmax ################################################################# rsd <- function(x,a,b) { ################################################################# # calcule le rapport écart-type sur écart-type maximal # de façon minimaliste sans s'embarasser de sd empirique et sd non biaisé return(100*sd(x) /( (b-a)/2 )) } # fin de fonction rsd ################################################################# sdr <- function(x,a,b) { ################################################################# # calcule le rapport écart-type sur écart-type maximal # en % return(100*sd(x)/sdmax(length(x),a,b)) } # fin de fonction sdmax ################################################################# ifiab <- function(x,a,b) { ################################################################# # renvoie l'indice de fiabilité # en % return(100-sdr(x,a,b)) } # fin de fonction ifiab ################################################################# bendist <- function(data,distcol=TRUE) { ################################################################# # calcule la distance entre les profils de la matrice des données # au sens de Benzécri (distance du chi2 centré) # on utilise les profils-colonnes si distcol=TRUE, # les profils-lignes sinon. # total général du tableau totgen <- sum(data) # fréquences conditionnelles nblig <- dim(data)[1] nbcol <- dim(data)[2] frq <- matrix(nrow=nblig,ncol=nbcol) fql <- vector(length=nblig,mode="numeric") fqc <- vector(length=nbcol,mode="numeric") somLig <- apply(data,1,sum) somCol <- apply(data,2,sum) pdlig <- 1:nblig pdcol <- 1:nbcol for (idl in pdlig) { for (jdc in pdcol) { frq[idl,jdc] <- data[idl,jdc] / totgen } # fin pour jdc } # fin pour idl for (idl in pdlig) { fql[idl] <- somLig[idl] / totgen } # fin pour idl for (jdc in pdcol) { fqc[jdc] <- somCol[jdc] / totgen } # fin pour jdc if (distcol) { # Distances colonnes distB <- matrix(nrow=nbcol,ncol=nbcol) row.names(distB) <- colnames(data) colnames(distB) <- colnames(data) for (ja in pdcol) { for (jb in pdcol) { distB[ja,jb] <- 0 } # fin pour ja } # fin pour ja for (ja in pdcol) { for (jb in pdcol) { ladist <- 0 for (i in pdlig) { denx <- fqc[ja]*fql[i] if (denx==0) { x <- 0 } else { x <- frq[i,ja] / denx } # fin si deny <- fqc[jb]*fql[i] if (deny==0) { y <- 0 } else { y <- frq[i,jb] / deny } # fin si ladist <- ladist + fql[i] * (x-y) * (x-y) #cat(ja,jb,i,fqc[ja],frq[i,ja],fqc[jb],fql[i],frq[i,jb],ladist,"\n") distB[ja,jb] <- ladist } # fin pour i } # fin pour ja } # fin pour ja } else { # Distances lignes distB <- matrix(nrow=nblig,ncol=nblig) row.names(distB) <- row.names(data) colnames(distB) <- row.names(data) for (ia in pdlig) { for (ib in pdlig) { distB[ia,ib] <- 0 } # fin pour ib } # fin pour ia for (ia in pdlig) { for (ib in pdlig) { ladist <- 0 for (j in pdcol) { denx <- fql[ia]*fqc[j] if (denx==0) { x <- 0 } else { x <- frq[ia,j] / denx } # fin si deny <- fql[ib]*fqc[j] if (deny==0) { y <- 0 } else { y <- frq[ib,j] / deny } # fin si ladist <- ladist + fqc[j] * (x-y) * (x-y) } # finpour j distB[ia,ib] <- ladist } # fin pour ib } # fin pour ia } # fin si return(as.dist(distB,diag=TRUE)) } # fin de fonction bendist ################################################################# decritClass <- function(cla) { ################################################################# noms <- cla$labels fusi <- cla$merge haut <- cla$height nbe <- dim(fusi)[1] nomc <- rep("",nbe) nbc <- 0 cat("Classe Hauteur Contenu \n") for (ide in (1:length(noms))) { nbc <- nbc + 1 cat(sprintf("%5d",nbc)) cat(" ",noms[ide]) cat("\n") } # fin pour ide for (ide in (1:nbe)) { nbc <- nbc + 1 cat(sprintf("%5d",nbc)) cat(sprintf(" %6.0f ",haut[ide])) #cat(" ",fusi[ide,]) cdlc <- c("") for (edc in fusi[ide,]) { if (edc<0) { cdlc <- paste(cdlc,sprintf("%-8s",noms[-edc]),sep="") } else { cdlc <- paste(cdlc,sprintf("%-8s",nomc[edc]),sep="") } # fin si } # fin pour cat(cdlc) nomc[ide] <- cdlc #cat(" donc en ",ide," : ", nomc[ide]) cat("\n") } # fin pour ide } # fin de fonction decritClass ################################################################# verifSol <- function(data,numg,formule) { ################################################################# if (missing(data)) { cat(" syntaxe : verifSol(data,numg,formule) ) \n") cat(" cette fonction vérifie si la formule et le groupe correspondent.\n") cat(" exemple : verifSol(raphv100,1,c(-30,63)) \n") return() } # fin si cat("Vérification de la formule ",formule," pour le groupe ",numg," dans les données ",data$basename,"\n") eff <- table(data$grps)[numg] cat(" nombre de lignes dans le groupe ",numg," : ",eff,"\n") pdi <- 1:length(formule) for (ind in pdi) { edf <- formule[ind] if (ind==1) { if (edf>0) { cnd <- data$dac[,edf]==1 } else { cnd <- data$dac[,-edf]==0 } # fin si } else { if (edf>0) { cnd <- cnd & data$dac[,edf]==1 } else { cnd <- cnd & data$dac[,-edf]==0 } # fin si } # fin si } # fin pour nbv <- sum(cnd) cat(" nombre de lignes vérifiant la formule : ",nbv,"\n") w1 <- which(data$grps==numg) w2 <- which(cnd) cat(" Groupe : ",w1,"\n") cat(" Formule : ",w2,"\n") oui <- 0 if ((length(w1)==length(w2))) { if (sum(abs(w1-w2))==0) { oui <- 1 } # fin si } # fin si if (oui==1) { cat(" oui, numéro de groupe et formule correspondent.\n") } else { cat(" non, numéro de groupe et formule ne correspondent pas.\n") } # fin si } # fin de fonction verifSol ################################################################# ################################################################# ## ## fonctions pour la statistique lexicale ## ################################################################# ################################################################# ################################################################# ucfirst <- function(chaine) { # renvoie la chaine avec l'initiale en majuscule ################################################################# return(paste(toupper(substr(chaine,1,1)),tolower(substr(chaine,2,nchar(chaine))),sep="")) } # fin de fonction ucfirst ################################################################# analexies <- function(texte,minu=TRUE,dbg=FALSE,show=TRUE) { ################################################################# # analyse lexicale d'un texte : on détermine les mots du texte # et leurs occurrences library(hash) if (missing(texte)) { cat("Syntaxe : res <- analexies(texte) \n") cat(" res$nmots contient le nombre de mots, res$nmotsd le nombre de mots différents, \n") cat(" res$tmots est le tableau des mots et res$toccs le tableau des mots trié par fréquence ;\n") cat(" de plus res$hmots est un tableau associatif (\"hash\") des mots. \n") return() } # fin si # nettoyage du texte tac <- texte if (minu) { tac <- tolower(tac) } tac <- gsub("[';.?:!(),]"," ",tac) tac <- gsub("--","",tac) tac <- gsub('\"',' ',tac) tac <- gsub("[«»]","",tac) tac <- ghtrim(tac) if (dbg) { cat("Texte avant : \n") cat(texte) cat("\n") cat("Texte après : \n") cat("*",tac,"*",sep="") cat("\n") } # fin de si # découpage en mots tbdm <- strsplit(tac," +",perl=TRUE) nbm <- 0 nbmd <- 0 hdm <- hash() for (mot in tbdm[[1]]) { if (mot!="") { nbm <- nbm + 1 if (has.key(mot,hdm)) { hdm[[mot]] <- hdm[[mot]] + 1 } else { nbmd <- nbmd + 1 hdm[[mot]] <- 1L } # fin si if (length(hdm[[mot]])==0) { hdm[[mot]] <- 1 nbmd <- nbmd + 1 } # fin si } # fin si } # fin pour # structuration en tableau tdm <- matrix(nrow=nbmd,ncol=1) ldm <- matrix(nrow=nbmd,ncol=1) idm <- 0 hhdm <<- hdm for (mot in keys(hdm)) { idm <- idm + 1 if (length(hdm[[mot]])==0) { hdm[[mot]] <- 1 } # if (dbg) { cat(" mot ",idm," pour ldm = ",mot," occ =",hdm[[mot]],"\n") } ldm[idm,1] <- mot tdm[idm,1] <- hdm[[mot]] } # fin pour row.names(tdm) <- ldm colnames(tdm) <- "occ" # tableau des occurences décroissantes idx <- rev(order(tdm[,1])) tdo <- matrix(nrow=nbmd,ncol=1) tdo[,1] <- tdm[idx] row.names(tdo) <- ldm[idx] colnames(tdo) <- "occ" if (show) { cat(" ",nbm,"mots en tout dont ",nbmd," mots distincts.\n") cat(paste(" chaque mot est donc répété ",sprintf("%9.2f",nbm/nbmd)," fois en moyenne.",sep=""),"\n") cat("\n") } # fin si if (dbg) { for (mot in keys(hdm)) { cat(sprintf(" %-30s",mot),sprintf(" %5d",hdm[[mot]]),"\n") } # fin pour } # fin de si return(list(nmots=nbm,hmots=hdm,nmotds=nbmd,tmots=tdm,toccs=tdo)) } # fin de fonction analexies ################################################################# cpt <- function(ldf,ldm,fs="") { ################################################################# library(hash) if (missing(ldm)) { cat(" syntaxe : tdo <- cpt(fichiers,mots[,fic_sor]) \n") cat(" renvoie un tableau qui dénombre les mots indiqués dans les fichiers.\n") cat(" le troisième paramètre stocke les résultats dans un fichier texte.\n") cat(" exemples : tdo <- cpt(\"bete.txt candide.txt\",\"maison temps train\") \n") cat(" tdf <- cpt(\"bete.txt candide.txt\",\"maison temps train\",\"resultat.txt\")\n") return() } # fin si # préparation des noms de fichier fics <- strsplit(ldf," ",perl=TRUE) nbf <- 0 nldf <- c() for (nfic in fics[[1]]) { if (nfic!="") { nbf <- nbf + 1 #cat(" fichier ",nbf," : ",nfic,"\n") nldf <- c(nldf,nfic) } # fin si } # fin pour # préparation des mots mots <- strsplit(ldm," ",perl=TRUE) nbm <- 0 nldm <- c() for (mot in mots[[1]]) { if (mot!="") { nbm <- nbm + 1 #cat(" mot ",nbm," : ",mot,"\n") nldm <- c(nldm,mot) } # fin si } # fin pour # initialisation du tableau résultat tres <- matrix(nrow=nbf,ncol=nbm,rep(0,nbm*nbf)) row.names(tres) <- nldf colnames(tres) <- nldm # passage en revue des fichiers via analexies idf <- 0 for (fic in nldf) { idf <- idf + 1 cat(" fichier ",idf," / ",nbf," : ",fic,"\n") adf <- analexies(lit.texte(fic)) idm <- 0 for (mot in nldm) { idm <- idm + 1 if (has.key(mot,adf$hmots)) { tres[idf,idm] <- adf$hmots[[mot]] } # fin si } # fin pour mot } # fin pour fic if (fs!="") { sink(fs) print(tres,quote=FALSE) sink() cat(" vous pouvez utiliser ",fs,"\n") } # fin si return(tres) } # fin de fonction cpt ################################################################# nbmots <- function(chen) { ################################################################# return(length(mots(chen))) } # fin de fonction nbmots ################################################################# mots <- function(chen) { ################################################################# library(stringr) return(unlist(strsplit(str_trim(chen),"\\s+",perl=TRUE))) } # fin de fonction mots ################################################################# mot <- function(chen,num) { ################################################################# library(stringr) words <- mots(chen) if (num<=0) { return("") } if (num>length(words)) { return("") } return( words[num] ) } # fin de fonction mot ################################################################# ################################################################# ## ## fin des fonctions pour la statistique lexicale ## ################################################################# ################################################################# ################################################################# pchShow <- function(extras = c("*",".", "o","O","0","+","-","|","%","#"), cex = 3, ## good for both .Device=="postscript" and "x11" col = "red3", bg = "gold", coltext = "brown", cextext = 1.2, main = paste("plot symbols : points (... pch = *, cex =", cex,")")) { ################################################################# nex <- length(extras) np <- 26 + nex ipch <- 0:(np-1) k <- floor(sqrt(np)) dd <- c(-1,1)/2 rx <- dd + range(ix <- ipch %/% k) ry <- dd + range(iy <- 3 + (k-1)- ipch %% k) pch <- as.list(ipch) # list with integers & strings if(nex > 0) pch[26+ 1:nex] <- as.list(extras) plot(rx, ry, type="n", axes = FALSE, xlab = "", ylab = "", main = main) abline(v = ix, h = iy, col = "lightgray", lty = "dotted") for(i in 1:np) { pc <- pch[[i]] ## 'col' symbols with a 'bg'-colored interior (where available) : points(ix[i], iy[i], pch = pc, col = col, bg = bg, cex = cex) if(cextext > 0) text(ix[i] - 0.3, iy[i], pc, col = coltext, cex = cextext) } } # fin de fonction pchShow ################################################################# dfSansNA <- function(dfAvecNA) { ################################################################# # suppression des données manquantes cat(" au départ, on a ",dim(dfAvecNA)," valeurs\n") nblig <- nrow(dfAvecNA) pdl <- 1:nblig nbcol <- ncol(dfAvecNA) pdc <- 1:nbcol masq <- rep(TRUE,nblig) for (idl in pdl) { ok <- TRUE for (jdc in pdc) { if (is.na(dfAvecNA[idl,jdc])) { ok <- FALSE } } # fin pour masq[idl] <- ok } # fin pour dfOK <- dfAvecNA[masq,] cat(" au final, on garde ",dim(dfOK)," valeurs\n") return(dfOK) } # fin de fonction dfSansNA ################################################################# ################################################################# ## ## fonctions pour les régressions logistiques et l'étude de la discordance ## ################################################################# ################################################################# # un data.frame dfRLB doit toujours avoir la cible en colonne 1 ################################################################# rlobin <- function(ql,qt,...) { ################################################################# # un simples alias pour regressionLogistiqueBinaire mode court dfqlqt <- data.frame(cbind(ql,qt)) decritModeleLogistiqueBinaire(dfqlqt,details=FALSE,sigvar=FALSE,...) } # fin de fonction rlobin ################################################################# regressionLogistiqueBinaire <- function(ql,qt,det=FALSE,sigvar=FALSE,...) { ################################################################# # un simples alias pour regressionLogistiqueBinaire mode long dfqlqt <- data.frame(cbind(ql,qt)) decritModeleLogistiqueBinaire(dfqlqt,details=det,sigvar=sigvar,...) } # fin de fonction regressionLogistiqueBinaire ################################################################# decritModeleLogistiqueBinaire <- function(dfRLB,details=FALSE,sigvar=FALSE,seuil=-1,autreData=NULL,titreAutreData="autres données",titre="",baseF="",tailleTitre=2.5,thresh=FALSE) { ################################################################# # la variable à prédire est en colonne 1 # si on met details=TRUE cette fonction fournit l'auroc avec un CI (intervalle de confiance), # les coefficients avec leur CI et la liste des seuils avec sensibilité, spécificité # de façon à pouvoir choisir le seuil de séparation # si on met avec sigvar=TRUE on ne renvoie que les variables significatives # si seuil est > 0 on calcule les valeurs binaires prédites et on calcule les # bien classées, la discordance... # si autreData est fourni, on évalue la performance du modèle sur ces autres données # mais la colonne 1 doit correspondre à la cible binaire # si thresh est à TRUE, on affiche tous les seuils vu library(ROCR) # library(DiagnosisMed) # non disponible depuis R > 3.0 library(caret) # pour confusionMatrix laql <- dfRLB[,1] titre2 <- "Cible binaire" if (titre!="") { titre2 <- paste(titre2,":",titre) } try( decritQL(titre2,laql,"0 1",details) ) qlbin <- dfRLB[,1] modele <- glm( qlbin ~ . ,data=dfRLB[,-1,drop=FALSE],family="binomial") resmod <- summary(modele) #lesCoef <- cbind(resmod$coefficients,confint(modele)) #etendue <- lesCoef[,6]-lesCoef[,5] #lesCoef <- cbind(lesCoef,etendue) yPredites <- predict(modele,newdata=dfRLB,type="response") vauroc <- aurocQlPred(dfRLB[,1],yPredites) if (details) { print(resmod) } # fin si cat("\nAuroc (ROCR) = ",vauroc,"\n") # affichage détaillé éventuel if (details) { lesCoef <- cbind(resmod$coefficients,confint(modele)) etendue <- lesCoef[,6]-lesCoef[,5] lesCoef <- cbind(lesCoef,etendue) print(lesCoef) #cat("\nROC (DiagnosisMed) \n") #resroc <- ROC(qlbin,yPredites) cat("\nDétails par seuil (gH)\n") sensSpec(qlbin,yPredites,details=thresh) } # fin si # liste éventuelle des variables significatives if (sigvar) { nbsigv <- 0 lvs <- "" for (idl in (1:dim(resmod$coefficients)[1])) { if (resmod$coefficients[idl,"Pr(>|z|)"]<0.10) { #cat(" ",idl,row.names(resmod$coefficients)[idl],"\n") lvs <- paste(lvs,row.names(resmod$coefficients)[idl],sep='","') nbsigv <- nbsigv + 1 } ; # fin si } # fin pour idl if (nbsigv==0) { cat("(aucune variable significatives)\n") } else { cat("voici les ",nbsigv," variables significatives : ") cat(lvs) cat("\n") } # fin si } # fin si # si un seuil est fourni, on analyse les valeurs binaires prédites if (seuil>0) { cats(paste(" Analyse des valeurs binaires prédites pour le seuil ",seuil)) ypredbin <- ifelse(yPredites<seuil,0,1) bc <- sum(qlbin==ypredbin) nb <- nrow(dfRLB) pctBc <- 100*bc/nb cat(" pct bien classés = ",pctBc) catn() # discordance(qlbin,ypredbin,matPen(2),c("0","1")) titre2 <- "Comparaison binaire org/prédite" if (titre!="") { titre2 <- paste(titre2,"pour",titre) } feps1 <- "" if (baseF!="") { feps1 <- paste(baseF,"_hist.eps",sep="") } #cat("data\n") #print(table(ypredbin)) #cat("reference\n") #print(table(qlbin)) if (details) { cats("compareScoresBinaires") compareScoresBinaires(valBin1=qlbin,valBin2=ypredbin,titre=titre2,graphique=detais,fichier=feps1,eps=TRUE,details=FALSE) } # fin si if (details) { cats("confusionMatrix") } # fin si fypredbin <- as.factor(ypredbin) levels(fypredbin) <- c(0,1) fqlbin <- as.factor(qlbin) levels(fqlbin) <- c(0,1) cm <- caret::confusionMatrix(data=fypredbin,reference=fqlbin,positive="1") if (details) { print( cm ) } # fin si mRlb <- decritRLB(titre=titre,df=dfRLB,print=TRUE) #cats("mRlb est ici") #print(mRlb) titre2 <- "Régression logistique" if (titre!="") { titre2 <- paste(titre2,"pour",titre) } feps2 <- "" if (baseF!="") { feps2 <- paste(baseF,"_rlb.eps",sep="") } traceRLB(objRlb=modele,ql=qlbin,seuil=seuil,titre=titre2,fsor=feps2,cexm=tailleTitre) } # fin si if (!is.null(autreData)) { cats(paste("Performance du modèle sur ",titreAutreData," dimension ",dims(autreData))) yPredites2 <- predict(modele,newdata=autreData,type="response") autreqlbin <- autreData[,1] vauroc2 <- aurocQlPred(autreqlbin,yPredites2) cat("Nouvelle auroc = ",vauroc2,"\n") ypredbin2 <- ifelse(yPredites2<seuil,0,1) vcmp <- compareScoresBinaires(valBin1=autreqlbin,valBin2=ypredbin2,titre="Comparaison binaire org/prédite (nouvelle cible)",graphique=TRUE) return(list(vauroc2,vcmp)) } # fin si if (sigvar) { return(vauroc) } else { if (exists("mRlb")) { return(invisible(mRlb)) } } } # fin de fonction decritModeleLogistiqueBinaire ################################################################# rchModeleLogistique <- function(df,printres=FALSE) { ################################################################# # la variable à prédire est forcément en colonne 1 cible <- df[,1] library(ROCR) ##mdc(df,meilcor=FALSE) # étude du modèle complet, # des modèles à 1 variable # des modèles à n-1 variables nbvar <- ncol(df) - 1 # car on retire la cible fnbv <- sprintf("%02dV",nbvar) nbcdr <- 3 + nbvar # car on rajoute AIC en colonne 1, il y a la constante et AUROC en fin nbmod <- 1 + 2*nbvar + 3 # les 3 derniers modèles sont issus de step matres <- matrix(nrow=nbmod,ncol=nbcdr) colnames(matres) <- c("AUROC","(Intercept)",colnames(df)[-1],"AIC") rownames(matres) <- c(paste("M",fnbv,sprintf("%02d",0:nbvar),sep=""), paste("M",fnbv,sprintf("%03d",-(1:nbvar)),sep=""), paste("M",fnbv,c("BS","FS","MS"),sep="")) pdv <- 1:nbmod # boucle sur les modèles models <- glm( cible ~ . ,data=na.omit(df[,-1,drop=FALSE]),family="binomial") # modèle saturé utilisé par step model0 <- glm( cible ~ 1 ,data=na.omit(df[,-1,drop=FALSE]),family="binomial") # modèle minimal utilisé par step for (idm in pdv) { tmpData <- na.omit(df[,-1,drop=FALSE]) if (idm==1) { # modèle complet modele <- glm( cible ~ .,data=tmpData,family="binomial") } # fin si if ((idm>1) & (idm<=nbvar+1)) { # modèles à 1 variable tmpData <- na.omit(df[,idm,drop=FALSE]) modele <- glm( cible ~ .,data=tmpData,family="binomial") } # fin si if ((idm>nbvar+1) & (idm<nbmod-2)) { # modèles à n-1 variables tmpData <- na.omit(df[,c(-1,-(idm-nbvar)),drop=FALSE]) modele <- glm( cible ~ .,data=tmpData,family="binomial") } # fin si if ((idm==nbmod-2)) { # Sélection arrière modele <- step(models,direction="backward",trace=0) } # fin si if ((idm==nbmod-1)) { # Sélection avant modele <- step(models,direction="forward",trace=0) } # fin si if ((idm==nbmod)) { # Sélection mixte modele <- step(models,direction="both",trace=0) } # fin si # on a le modèle, on extrait les valeurs qui nous intéressent #cat("coefficients pour idm = ",idm," / ",nbmod,": \n") #print(modele$coefficients) #print(dim(matres)) #print(length(modele$coefficients)) #attends("ok ? ") lescoef <- modele$coefficients matres[idm,nbcdr] <- modele$aic matres[idm,names(lescoef)] <- lescoef yPredites <- predict(modele,newdata=tmpData,type="response") matres[idm,1] <- aurocQlPred(cible,yPredites) } # fin pour # et on affiche si print=TRUE if (printres) { cat("\nMatrice des aic et des coefficients de la RLB\n") print(round(matres,3)) # choix du modèle à retenir cat("\nMeilleur modèle au sens d'AIC \n") colSel <- nbcdr idm <- matres[,colSel]==min(matres[,colSel]) print(round(matres[idm,,drop=FALSE],4)) cat("\nMeilleur modèle au sens d'AUROC \n") colSel <- 1 idm <- matres[,colSel]==max(matres[,colSel]) print(round(matres[idm,,drop=FALSE],4)) } # fin si return(matres) } # fin de fonction rchModeleLogistique ################################################################# analyseCoefficientsModeleLogistique <- function(df) { ################################################################# # la variable à prédire est forcément en colonne 1 laQL <- df[,1] #mdc(df,meilcor=FALSE) # étude du modèle complet, # des modèles à 1 variable # des modèles à n-1 variables # du meilleur modèle nomlig <- c("Corr") nbrlig <- length(nomlig) nbvar <- ncol(df) - 1 # car on retire la cible matcoef1 <- matrix(nrow=nbrlig,ncol=nbvar) rownames(matcoef1) <- nomlig nomcol <- colnames(df) colnames(matcoef1) <- nomcol[-1] pdv <- 1:nbvar for (idl in pdv) { laQT <- df[,1 + idl] matcoef1[1,idl] <- cor(laQL,laQT) } # fin pour idl matcoef2 <- rchModeleLogistique(df,printres=FALSE) nbl <- nrow(matcoef2) matcoef <- rbind(matcoef1,matcoef2[1:(nbl-3),2+(1:nbvar)]) print(round(matcoef,3)) } # fin de fonction analyseCoefficientsModeleLogistique ################################################################# decritRLB <- function(titre,df,details=FALSE,print=FALSE,seuil=0.5,pause=FALSE) { ################################################################# # library(DiagnosisMed) # description modèle régression logistique binaire vql <- df[,1,drop=FALSE] nbql1 <- sum(vql==1) names(df)[1] <- "vql" rlb <- glm( vql ~ . ,data=df,family="binomial") ypred <- predict(rlb,data=df,type="response") dfpred <- data.frame(cbind(df[,1],ypred)) names(dfpred) <- c("qlb","ypred") idx <- order(dfpred$ypred,decreasing=TRUE) dfpred <- dfpred[idx,] if (pause) { browser() } # finsi va <- aurocQlPred(df[,1],ypred) vPred <- ifelse(ypred>seuil,1,0) res <- compareScoresBinaires(valBin1=df[,1],valBin2=vPred,titre=titre,moda=c("0","1"),details=details) br <- bestCorDf(df[,-1]) # intervalle de confiance de l'auroc # resroc <- ROC(gold=df[,1],test=ypred,Plot=FALSE,Print=FALSE) # lesva <- resroc$AUC.summary lesva <- aurocQlPred(df[,1],ypred,TRUE) lesData <- df nbcm <- ncol(lesData)-1 if (nbcm<=8) { ndv <- paste(names(lesData[,-1,drop=FALSE]),collapse=" ") } else { ndv <- paste(paste(names(lesData[,-1])[1:8],collapse=" "),"...",sep="") } # finsi #catss("nv est ici") #print(names(lesData[,-1,drop=FALSE])) #print(nbcm) #print(ndv) mr <- data.frame(titre,nrow(lesData),nbcm,nbql1,rlb$aic,lesva[2],lesva[1],lesva[3],res[2],res[1],as.numeric(br[1,4]),as.numeric(br[1,3]),ndv) colnames(mr) <- c("Titre","nblig","nbVar","nbCible","AIC","AUROC","AUROCinf","AUROCsup","%BC_0.5","discord","rsmax","rpmax","lesVariables") row.names(mr) <- 1:nrow(mr) if (print) { print(mr) } return(mr) } # fin de fonction decritRLB ################################################################# traceRLB <- function(objRlb,ql,couleurs=c("green","red"),seuil=-1,titre="Régression logistique",fsor="",cexm=2) { ################################################################# ypred <- objRlb$fitted.values idx <- order(ypred) nypred <- ypred[idx] coul <- couleurs[ 1+ql[idx] ] if (fsor!="") { postscript(fsor) cat("vous pouvez utiliser ",fsor,"\n") } # fin si plot(nypred,ylim=c(0,1),col=coul,pch=19,xlab="",ylab="",main=titre,cex.main=cexm) if (seuil>-1) { abline(h=seuil) } # finsi if (fsor!="") { dev.off() } ; # fin si } # fin de fonction traceRLB ################################################################# modelesRLB <- function(titre,df,vectChaines,base="",maxdec=0,bestModel=0,return=FALSE) { ################################################################# #library(DiagnosisMed) # pour la fonction ROC # produit de "jolis" tableaux résumés de plusieurs RLB pour les mêmes données # exemple : modelesRLB(titre="Malah",df=ma,vectChaines=vdc,base="FCS",maxdec=3) # où vdc contient c( "x y", "x u v ", ...) pour choisir les variables # x en col. 1 est la ql et les autres col sont des qt # noms des modèles et des variables tc <- paste("Modèles RLB pour ",titre,sep="") cats(tc) nbm <- length(vectChaines) ddm <- matrix(nrow=nbm,ncol=3) colnames(ddm) <- c("Data","nbVar","Variables") pdm <- 1:nbm row.names(ddm) <- pdm ddm[,1] <- paste(base,pdm,sep="") for (idm in pdm) { titrec <- ddm[idm,1] ndv <- vectChaines[idm] if (ndv==".") { lesData <- df } else { lesData <- df[,chaineEnListe(ndv)] } # fin si ddm[idm,2] <- sprintf("%3d",ncol(lesData)) ddm[idm,3] <- lesVariables(df=lesData,lng=7,maxVar=8) # description modèle régression logistique binaire vbin <- lesData[,1] names(lesData)[1] <- "vbin" rlb <- glm( vbin ~ . ,data=lesData,family="binomial") ypred <- predict(rlb,data=lesData,type="response") # auroc et son intervalle de confiance va <- aurocQlPred(vbin,ypred) vPred <- ifelse(ypred<0.5,0,1) # par défaut, 0.5 a priori # score de discordance et taux de bien classés res <- compareScoresBinaires(valBin1=vbin,valBin2=vPred,titre=titrec,moda=c("0","1"),details=TRUE) # plus forts coefficients de corrélation br <- bestCor(lesData[,-1,]) cat("modèle ",idm," soit ",ddm[idm,1]," best cor = ",br[1,],"\n") # intervalle de confiance de l'auroc #resroc <- with(lesData,ROC(gold=vbin,test=ypred,Plot=FALSE,Print=FALSE)) #lesva <- resroc$AUC.summary lesva <- aurocQlPred(vbin,ypred,TRUE) #cat("### ",lesva,"\n") nbcm <- ncol(lesData)-1 if (nbcm<8) { ndv <- paste(colnames(lesData[,-1]),collapse=" ") } else { ndv <- paste(paste(colnames(lesData[,-1])[1:8],collapse=" "),"...",sep="") } # finsi mr <- data.frame(titrec,nrow(lesData),nbcm,rlb$aic,lesva[2],lesva[1],lesva[3],res[2],res[1],as.numeric(br[1,4]),as.numeric(br[1,3]),ndv) colnames(mr) <- c("Titre","nblig","nbVar","AIC","AUROC","AUROCinf","AUROCsup","%BC_0.5","discord","rsmax","rpmax","lesVariables") row.names(mr) <- 1:nrow(mr) dmc <- mr if (idm==1) { dm <- dmc } else { dm <- rbind(dm,dmc) } # fin si # si bestModel est non nul, on conserve les données et la régression if (idm==bestModel) { bdmc <- NA # était resroc bql <- vbin bqt <- ypred } # fin si } # fin pour idm # si maxdec est non nul, on reformate les colonnes d'auroc et de discordance if (maxdec>0) { fmt <- paste(" %0.",maxdec,"f",sep="") for (idc in 3:11) { dm[,idc] <- sprintf(fmt,dm[,idc]) } # fin pour } # fin si print(ddm,quote=FALSE) catn() print(dm,quote=FALSE) catn() # si bestModel est non nul, on conserve les données et la régression if (bestModel>0) { # bien classés cat("Seuils et bien classés pour le modèle ",ddm[bestModel,1],"\n") # print(bdmc$test.best.cutoff) # sensSpec(qlb=bql,qt=bqt,details=FALSE) onbr <- nrow(bdmc$test.best.cutoff) tdbc <- matrix(nrow=1+onbr,ncol=4) tdbc[1+(1:onbr),c(1,3,4)] <- as.matrix(bdmc$test.best.cutoff[,c(1,2,5)]) colnames(tdbc) <- c("Seuil","%BC_seuil",names(bdmc$test.best.cutoff)[c(2,5)]) row.names(tdbc) <- c("A priori",row.names(bdmc$test.best.cutoff)) tdbc[1,1] <- 0.5 for (ids in 1:nrow(tdbc)) { nql <- ifelse(bqt>tdbc[ids,1],1,0) nbc <- sum( bql==nql) tau <- 100*nbc/length(bql) tdbc[ids,2] <- tau if (ids==1) { nvp <- sum( (bql==nql) & (bql==1) ) nvn <- sum( (bql==nql) & (bql==0) ) nfp <- sum( (bql!=nql) & (bql==0) ) nfn <- sum( (bql!=nql) & (bql==1) ) sens <- nvp/(nvp+nfn) spec <- nvn/(nfp+nvn) tdbc[ids,3] <- sens tdbc[ids,4] <- spec } # fin si } # fin pour ids print(round(tdbc,3)) } # fin si if (return) { return(dm) } } # fin de fonction modelesRLB ################################################################# modelesRLIMetavir <- function(titre,df,vectChaines,base="",maxdec=0,bestModel=0,pointsQt=TRUE,pointsMeta=TRUE,barresPred=TRUE) { ################################################################# library(pROC) # pour multiclass.roc() # produit de "jolis" tableaux résumés de plusieurs RLI pour les mêmes données # exemple : modelesRLIMetavir(titre="Malah",df=ma,vectChaines=vdc,base="RLI-METAVIR",maxdec=3) # où vdc contient c( "x y", "x u v ", ...) pour choisir les variables # x en col. 1 est la qt réponse et les autres col sont les autres qt # noms des modèles et des variables mm <- modalitesMetavir() matpUnif <- matPen(taille=5,opt="unif") matpPond <- matPen(taille=5,opt="pond") tc <- paste("Modèles RLI pour ",titre,sep="") cats(tc) nbm <- length(vectChaines) ddm <- matrix(nrow=nbm,ncol=3) colnames(ddm) <- c("Data","nbVar","Variables") pdm <- 1:nbm row.names(ddm) <- pdm metaF <- df[,1] ddm[,1] <- paste(base,pdm,sep="") for (idm in pdm) { titrec <- ddm[idm,1] ndv <- vectChaines[idm] if (ndv==".") { lesData <- df } else { lesData <- df[,chaineEnListe(ndv)] } # fin si ddm[idm,2] <- sprintf("%3d",ncol(lesData)) ddm[idm,3] <- lesVariables(df=lesData,lng=7,maxVar=8) # description modèle régression linéaire metavir <- lesData[,1] names(lesData)[1] <- "metavir" nbind <- length(metavir) rli <- lm( metavir ~ . ,data=lesData) srli <- summary(rli) r2a <- srli$adj.r.squared br <- bestCor(lesData[,-1]) cat("modèle ",idm," soit ",ddm[idm,1]," best cor = ",br[1,],"\n") ypred <- predict(rli,data=lesData) ypredMeta <- recadrage(v=ypred,vmin=0,vmax=4,out=1) diUnif <- discordance(score1=metavir,score2=ypredMeta,matpond=matpUnif,modalites=mm,titre1="Metavir",titre2="RLI",ref=1,nompond="uniforme") diProp <- discordance(score1=metavir,score2=ypredMeta,matpond=matpPond,modalites=mm,titre1="Metavir",titre2="RLI",ref=1,nompond="proportionnelle") tbcg <- round(100*sum(metavir==ypredMeta)/nbind,1) lesF4 <- df[,1]==4 tbcF4 <- round(100*sum(metavir[lesF4]==ypredMeta[lesF4])/sum(lesF4),1) mauroc <- multiclass.roc(response=metaF,predictor=ypredMeta) mauc <- as.numeric(mauroc$auc) mr <- data.frame(titrec,ncol(lesData)-1,r2a,diUnif,diProp,tbcg,tbcF4,mauc,as.numeric(br[1,4]),as.numeric(br[1,3]),lesVariables(lesData[,-1],8)) colnames(mr) <- c("Titre","nbVar","R2a","discUnif","discProp","%BC","%BC_F4","mAUROC","rsmax","rpmax","Variables") row.names(mr) <- 1:nrow(mr) dmc <- mr if (idm==1) { dm <- dmc } else { dm <- rbind(dm,dmc) } # fin si # si bestModel est non nul, on conserve les données et la régression if (idm==bestModel) { bestData <- lesData bestRli <- rli bestPredQt <- ypred bestPred <- ypredMeta bestDiProp <- diProp } # fin si } # fin pour idm # si maxdec est non nul, on reformate les colonnes d'auroc et de discordance if (maxdec>0) { fmt <- paste(" %0.",maxdec,"f",sep="") for (idc in 3:10) { dm[,idc] <- sprintf(fmt,dm[,idc]) } # fin pour } # fin si print(ddm,quote=FALSE) catn() print(dm,quote=FALSE,right=FALSE) catn() # si bestModel est non nul, analyse du meilleur modèle (a posteriori) if (bestModel>0) { nomBest <- paste(ddm[bestModel,1]," (disc. prop = ",sprintf("%0.3f",bestDiProp),")",sep="") leTitre <- paste("Meilleur modèle = numéro",bestModel,"soit",nomBest) cats(leTitre) cat("ses variables sont : \n") cat(lesVariables(bestData),"\n") compareScoresMetavir(valMeta=metavir,predMeta=bestPredQt,titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsQt) compareScoresMetavir(valMeta=metavir,predMeta=bestPred, titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsMeta) compareScoresMetavir(valMeta=metavir,predMeta=bestPred, titre=nomBest,pointilles="dotted",barres=barresPred ,points=FALSE) } # fin si } # fin de fonction modelesRLIMetavir ################################################################# modelesLDAMetavir <- function(titre,df,vectChaines,base="",maxdec=0,bestModel=0,pointsQt=TRUE,pointsMeta=TRUE,barresPred=TRUE,details=TRUE) { ################################################################# library(MASS) # pour la fonction lda() library(pROC) # pour multiclass.roc() # produit de "jolis" tableaux résumés de plusieurs LDA pour les mêmes données # exemple : modelesMDAMetavir(titre="Malah",df=ma,vectChaines=vdc,base="RLI-METAVIR",maxdec=3) # où vdc contient c( "x y", "x u v ", ...) pour choisir les variables # x en col. 1 est la qt réponse et les autres col sont les autres qt # noms des modèles et des variables mm <- modalitesMetavir() matpUnif <- matPen(taille=5,opt="unif") matpPond <- matPen(taille=5,opt="pond") # affichage du titre tc <- paste("Modèles LDA pour ",titre,sep="") cats(tc) nbm <- length(vectChaines) ddm <- matrix(nrow=nbm,ncol=3) colnames(ddm) <- c("Data","nbVar","Variables") pdm <- 1:nbm row.names(ddm) <- pdm metaF <- df[,1] ddm[,1] <- paste(base,pdm,sep="") for (idm in pdm) { titrec <- ddm[idm,1] ndv <- vectChaines[idm] if (ndv==".") { lesData <- df } else { lesData <- df[,chaineEnListe(ndv),drop=FALSE] } # fin si ddm[idm,2] <- sprintf("%3d",ncol(lesData)) ddm[idm,3] <- lesVariables(df=lesData,lng=7,maxVar=8) # description modèle analyse discriminante metavir <- lesData[,1] names(lesData)[1] <- "metavir" nbind <- length(metaF) rlda <- lda( metavir ~ . ,data=lesData[,-1,drop=FALSE]) srlda <- summary(rlda) dev <- NA br <- bestCor(lesData[,-1]) cat("modèle ",idm," soit ",ddm[idm,1]," best cor = ",br[1,],"\n") ypred <- predict(rlda,newdata=lesData,type="class") ypredMeta <- as.integer(ypred$class) - 1 ypredQt <- ypred$posterior diUnif <- discordance(score1=metavir,score2=ypredMeta,matpond=matpUnif,modalites=mm,titre1="Metavir",titre2="LDA",ref=1,nompond="uniforme") diProp <- discordance(score1=metavir,score2=ypredMeta,matpond=matpPond,modalites=mm,titre1="Metavir",titre2="LDA",ref=1,nompond="proportionnelle") tbcg <- round(100*sum(metavir==ypredMeta)/nbind,1) lesF4 <- metavir==4 tbcF4 <- round(100*sum(metavir[lesF4]==ypredMeta[lesF4])/sum(lesF4),1) mauroc <- multiclass.roc(response=metaF,predictor=ypredMeta) mauc <- as.numeric(mauroc$auc) # mauc <- (-999) mr <- data.frame(titrec,ncol(lesData)-1,dev,diUnif,diProp,tbcg,tbcF4,mauc,as.numeric(br[1,4]),as.numeric(br[1,3]),lesVariables(lesData[,-1,drop=FALSE],8)) colnames(mr) <- c("Titre","nbVar","Dev","discUnif","discProp","%BC","%BC_F4","mAUROC","rsmax","rpmax","Variables") row.names(mr) <- 1:nrow(mr) dmc <- mr if (idm==1) { dm <- dmc } else { dm <- rbind(dm,dmc) } # fin si # si bestModel est non nul, on conserve les données et la régression if (idm==bestModel) { bestData <- lesData bestRlda <- rlda bestPredQt <- ypredQt bestPred <- ypredMeta bestDiProp <- diProp } # fin si } # fin pour idm # si maxdec est non nul, on reformate les colonnes d'auroc et de discordance if (maxdec>0) { fmt <- paste(" %0.",maxdec,"f",sep="") for (idc in 3:10) { dm[,idc] <- sprintf(fmt,dm[,idc]) } # fin pour } # fin si print(ddm,quote=FALSE) catn() print(dm,quote=FALSE,right=FALSE) catn() # si bestModel est non nul, analyse du meilleur modèle (a posteriori) if (bestModel>0) { nomBest <- paste(ddm[bestModel,1]," (disc. prop = ",sprintf("%0.3f",bestDiProp),")",sep="") leTitre <- paste("Meilleur modèle LDA = numéro",bestModel,"soit",nomBest) cats(leTitre) cat("Ses variables sont : \n") cat(lesVariables(bestData),"\n") matMeta <- matrix(data=0:4,nrow=nrow(bestPredQt),ncol=ncol(bestPredQt),byrow=TRUE) bestPredQtVal <- rowSums(bestPredQt*matMeta) compareScoresMetavir(valMeta=metavir,predMeta=bestPredQtVal,titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsQt) compareScoresMetavir(valMeta=metavir,predMeta=bestPred,titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsMeta) compareScoresMetavir(valMeta=metavir,predMeta=bestPred,titre=nomBest,pointilles="dotted",barres=barresPred,points=FALSE) confusionMatrix(reference=metavir,data=bestPred) } # fin si } # fin de fonction modelesLDAMetavir ################################################################# pctBcLda <- function(df,lavar,target) { ################################################################# library(MASS) # pour la fonction lda # renvoie le nombre et le pct de bien classés dans une LDA # avec un seul prédicteur tmod <- paste("mdcl <- lda(",target," ~ ",lavar,",data=df)",sep="") eval(parse(text=tmod)) prcl <- predict(mdcl,newdata=df) nbbc <- sum(df[,target]==prcl$class) pctbc <- round(100*nbbc/length(df[,target]),3) return( c(nbbc,pctbc) ) } # fin de fonction pctBcLda ################################################################# bestGroupRep <- function(data,ldg,target,criter="BC") { ################################################################# library(MASS) # pour la fonction lda # à partir d'un data frame, d'une liste de goupe avec une plusieurs # variables par groupe et une cible pour LDA, on renvoie la meilleure # variable par groupe, le critère étant le taux de bien classés total # ou la corrélation de pearson if (missing(data)) { cat(" bestGroupRep : recherche la meilleur variable par groupe pour une cible donnée\n") cat(" syntaxe : bestGroupRep(data,ldg,target,criter) \n\n") stop() } ; # fin si cats(paste("Cible =",target,"critère =",criter)) nbg <- length(ldg) matg <- matrix(nrow=nbg,ncol=3) colnames(matg) <- c("nbBC","%BC","r.spearman") row.names(matg) <- paste("groupe",1:nbg,sep="") for (idg in 1:nbg) { cats(paste("Group ",idg," / ",nbg),"-") nco <- ldg[[idg]] nbv <- length(nco) mrs <- matrix(0,nrow=nbv,ncol=3) row.names(mrs) <- nco colnames(mrs) <- c("nbBC","%BC","r.spearman") for (idv in nco) { mrs[idv,(1:2)] <- pctBcLda(data,idv,target) mrs[idv,3] <- cor(data[,idv],data[,target],method="pearson") } # fin pour idv print(mrs) if (criter=="BC") { idm <- which.max(mrs[,"nbBC"]) } else { idm <- which.max(abs(mrs[,"r.spearman"])) } # fin si cat("\n") cat("meilleur représentant pour ",criter,": ",idm," soit ",row.names(mrs)[idm],"\n") row.names(matg)[idg] <- row.names(mrs)[idm] matg[idg,] <- mrs[idm,] } # fin pour idg return( list(target=target,results=matg,criter=criter) ) } # fin de fonction bestGroupRep ################################################################# modelesQDAMetavir <- function(titre,df,vectChaines,base="",maxdec=0,bestModel=0,pointsQt=TRUE,pointsMeta=TRUE,barresPred=TRUE) { ################################################################# library(MASS) # pour la fonction qda() library(pROC) # pour multiclass.roc() # produit de "jolis" tableaux résumés de plusieurs QDA pour les mêmes données # exemple : modelesMDAMetavir(titre="Malah",df=ma,vectChaines=vdc,base="RLI-METAVIR",maxdec=3) # où vdc contient c( "x y", "x u v ", ...) pour choisir les variables # x en col. 1 est la qt réponse et les autres col sont les autres qt # noms des modèles et des variables mm <- modalitesMetavir() matpUnif <- matPen(taille=5,opt="unif") matpPond <- matPen(taille=5,opt="pond") tc <- paste("Modèles QDA pour ",titre,sep="") cats(tc) nbm <- length(vectChaines) ddm <- matrix(nrow=nbm,ncol=3) colnames(ddm) <- c("Data","nbVar","Variables") pdm <- 1:nbm row.names(ddm) <- pdm metaF <- df[,1] ddm[,1] <- paste(base,pdm,sep="") for (idm in pdm) { titrec <- ddm[idm,1] ndv <- vectChaines[idm] if (ndv==".") { lesData <- df } else { lesData <- df[,chaineEnListe(ndv)] } # fin si ddm[idm,2] <- sprintf("%3d",ncol(lesData)) ddm[idm,3] <- lesVariables(df=lesData,lng=7,maxVar=8) # description modèle analyse discriminante metavir <- lesData[,1] names(lesData)[1] <- "metavir" nbind <- length(metaF) rlda <- qda( metavir ~ . ,data=lesData[,-1]) srlda <- summary(rlda) dev <- NA br <- bestCor(lesData[,-1]) cat("modèle ",idm," soit ",ddm[idm,1]," best cor = ",br[1,],"\n") ypred <- predict(rlda,newdata=lesData,type="class") ypredMeta <- as.integer(ypred$class) - 1 ypredQt <- ypred$posterior diUnif <- discordance(score1=metavir,score2=ypredMeta,matpond=matpUnif,modalites=mm,titre1="Metavir",titre2="QDA",ref=1,nompond="uniforme") diProp <- discordance(score1=metavir,score2=ypredMeta,matpond=matpPond,modalites=mm,titre1="Metavir",titre2="QDA",ref=1,nompond="proportionnelle") tbcg <- round(100*sum(metavir==ypredMeta)/nbind,1) lesF4 <- metavir==4 tbcF4 <- round(100*sum(metavir[lesF4]==ypredMeta[lesF4])/sum(lesF4),1) mauroc <- multiclass.roc(response=metaF,predictor=ypredMeta) mauc <- as.numeric(mauroc$auc) mr <- data.frame(titrec,ncol(lesData)-1,dev,diUnif,diProp,tbcg,tbcF4,mauc,as.numeric(br[1,4]),as.numeric(br[1,3])) colnames(mr) <- c("Titre","nbVar","Dev","discUnif","discProp","%BC","%BC_F4","mAUROC","rsmax","rpmax") row.names(mr) <- 1:nrow(mr) dmc <- mr if (idm==1) { dm <- dmc } else { dm <- rbind(dm,dmc) } # fin si # si bestModel est non nul, on conserve les données et la régression if (idm==bestModel) { bestData <- lesData bestRlda <- rlda bestPredQt <- ypredQt bestPred <- ypredMeta bestDiProp <- diProp } # fin si } # fin pour idm # si maxdec est non nul, on reformate les colonnes d'auroc et de discordance if (maxdec>0) { fmt <- paste(" %0.",maxdec,"f",sep="") for (idc in 3:10) { dm[,idc] <- sprintf(fmt,dm[,idc]) } # fin pour } # fin si print(ddm,quote=FALSE) catn() print(dm,quote=FALSE) catn() # si bestModel est non nul, analyse du meilleur modèle (a posteriori) if (bestModel>0) { nomBest <- paste(ddm[bestModel,1]," (disc. prop = ",sprintf("%0.3f",bestDiProp),")",sep="") leTitre <- paste("Meilleur modèle QDA = numéro",bestModel,"soit",nomBest) cats(leTitre) cat("ses variables sont : \n") cat(lesVariables(bestData),"\n") matMeta <- matrix(data=0:4,nrow=nrow(bestPredQt),ncol=ncol(bestPredQt),byrow=TRUE) bestPredQtVal <- rowSums(bestPredQt*matMeta) compareScoresMetavir(valMeta=metavir,predMeta=bestPredQtVal,titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsQt) compareScoresMetavir(valMeta=metavir,predMeta=bestPred,titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsMeta) compareScoresMetavir(valMeta=metavir,predMeta=bestPred,titre=nomBest,pointilles="dotted",barres=barresPred,points=FALSE) confusionMatrix(reference=metavir,data=bestPred) } # fin si } # fin de fonction modelesQDAMetavir ################################################################# modelesMDAMetavir <- function(titre,df,vectChaines,base="",maxdec=0,bestModel=0,pointsQt=TRUE,pointsMeta=TRUE,barresPred=TRUE) { ################################################################# library(mda) # pour la fonction mda() library(pROC) # pour multiclass.roc() # produit de "jolis" tableaux résumés de plusieurs MDA pour les mêmes données # exemple : modelesMDAMetavir(titre="Malah",df=ma,vectChaines=vdc,base="RLI-METAVIR",maxdec=3) # où vdc contient c( "x y", "x u v ", ...) pour choisir les variables # x en col. 1 est la qt réponse et les autres col sont les autres qt # noms des modèles et des variables mm <- modalitesMetavir() matpUnif <- matPen(taille=5,opt="unif") matpPond <- matPen(taille=5,opt="pond") tc <- paste("Modèles MDA pour ",titre,sep="") cats(tc) nbm <- length(vectChaines) ddm <- matrix(nrow=nbm,ncol=3) colnames(ddm) <- c("Data","nbVar","Variables") pdm <- 1:nbm row.names(ddm) <- pdm metaF <- df[,1] ddm[,1] <- paste(base,pdm,sep="") for (idm in pdm) { titrec <- ddm[idm,1] ndv <- vectChaines[idm] if (ndv==".") { lesData <- df } else { lesData <- df[,chaineEnListe(ndv)] } # fin si ddm[idm,2] <- sprintf("%3d",ncol(lesData)) ddm[idm,3] <- lesVariables(df=lesData,lng=7,maxVar=8) # description modèle analyse discriminante metavir <- lesData[,1] names(lesData)[1] <- "metavir" nbind <- length(metaF) rmda <- mda( metavir ~ . ,data=lesData[,-1]) srmda <- summary(rmda) dev <- rmda$deviance br <- bestCor(lesData[,-1]) cat("modèle ",idm," soit ",ddm[idm,1]," best cor = ",br[1,]," misclassif = ",attr(rmda$confusion,"error"),"\n") ypred <- predict(rmda,newdata=lesData,type="class") ypredMeta <- as.integer(ypred) - 1 ypredQt <- predict(rmda,newdata=lesData,type="posterior") diUnif <- discordance(score1=metavir,score2=ypredMeta,matpond=matpUnif,modalites=mm,titre1="Metavir",titre2="MDA",ref=1,nompond="uniforme") diProp <- discordance(score1=metavir,score2=ypredMeta,matpond=matpPond,modalites=mm,titre1="Metavir",titre2="MDA",ref=1,nompond="proportionnelle") tbcg <- round(100*sum(metavir==ypredMeta)/nbind,1) lesF4 <- metavir==4 tbcF4 <- round(100*sum(metavir[lesF4]==ypredMeta[lesF4])/sum(lesF4),1) mauroc <- multiclass.roc(response=metaF,predictor=ypredMeta) mauc <- as.numeric(mauroc$auc) mr <- data.frame(titrec,ncol(lesData)-1,dev,diUnif,diProp,attr(rmda$confusion,"error"),tbcg,tbcF4,mauc,as.numeric(br[1,4]), as.numeric(br[1,3]),lesVariables(lesData[,-1],8)) colnames(mr) <- c("Titre","nbVar","Dev","discUnif","discProp","MisClass","%BC","%BC_F4","mAUROC","rsmax","rpmax","Variables") row.names(mr) <- 1:nrow(mr) dmc <- mr if (idm==1) { dm <- dmc } else { dm <- rbind(dm,dmc) } # fin si # si bestModel est non nul, on conserve les données et la régression if (idm==bestModel) { bestData <- lesData bestRmda <- rmda bestPredQt <- ypredQt bestPred <- ypredMeta bestDiProp <- diProp } # fin si } # fin pour idm # si maxdec est non nul, on reformate les colonnes d'auroc et de discordance if (maxdec>0) { fmt <- paste(" %0.",maxdec,"f",sep="") for (idc in 3:10) { dm[,idc] <- sprintf(fmt,dm[,idc]) } # fin pour } # fin si print(ddm,quote=FALSE) catn() print(dm,quote=FALSE,right=FALSE) catn() # si bestModel est non nul, analyse du meilleur modèle (a posteriori) if (bestModel>0) { nomBest <- paste(ddm[bestModel,1]," (disc. prop = ",sprintf("%0.3f",bestDiProp),")",sep="") leTitre <- paste("Meilleur modèle MDA = numéro",bestModel,"soit",nomBest) cats(leTitre) cat("ses variables sont : \n") cat(lesVariables(bestData),"\n") matMeta <- matrix(data=0:4,nrow=nrow(bestPredQt),ncol=ncol(bestPredQt),byrow=TRUE) bestPredQtVal <- rowSums(bestPredQt*matMeta) compareScoresMetavir(valMeta=metavir,predMeta=bestPredQtVal,titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsQt) compareScoresMetavir(valMeta=metavir,predMeta=bestPred,titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsMeta) compareScoresMetavir(valMeta=metavir,predMeta=bestPred,titre=nomBest,pointilles="dotted",barres=barresPred,points=FALSE) confusionMatrix(reference=metavir,data=bestPred) } # fin si } # fin de fonction modelesMDAMetavir ################################################################# modelesFDAMetavir <- function(titre,df,vectChaines,base="",maxdec=0,bestModel=0,pointsQt=TRUE,pointsMeta=TRUE,barresPred=TRUE) { ################################################################# library(mda) # pour la fonction fda() library(pROC) # pour multiclass.roc() # produit de "jolis" tableaux résumés de plusieurs MDA pour les mêmes données # exemple : modelesMDAMetavir(titre="Malah",df=ma,vectChaines=vdc,base="RLI-METAVIR",maxdec=3) # où vdc contient c( "x y", "x u v ", ...) pour choisir les variables # x en col. 1 est la qt réponse et les autres col sont les autres qt # noms des modèles et des variables mm <- modalitesMetavir() matpUnif <- matPen(taille=5,opt="unif") matpPond <- matPen(taille=5,opt="pond") tc <- paste("Modèles FDA pour ",titre,sep="") cats(tc) nbm <- length(vectChaines) ddm <- matrix(nrow=nbm,ncol=3) colnames(ddm) <- c("Data","nbVar","Variables") pdm <- 1:nbm row.names(ddm) <- pdm metaF <- df[,1] ddm[,1] <- paste(base,pdm,sep="") for (idm in pdm) { titrec <- ddm[idm,1] ndv <- vectChaines[idm] if (ndv==".") { lesData <- df } else { lesData <- df[,chaineEnListe(ndv)] } # fin si ddm[idm,2] <- sprintf("%3d",ncol(lesData)) ddm[idm,3] <- lesVariables(df=lesData,lng=7,maxVar=8) # description modèle analyse discriminante metavir <- lesData[,1] names(lesData)[1] <- "metavir" nbind <- length(metaF) rmda <- fda( metavir ~ . ,data=lesData[,-1]) srmda <- summary(rmda) dev <- NA br <- bestCor(lesData[,-1]) cat("modèle ",idm," soit ",ddm[idm,1]," best cor = ",br[1,]," misclassif = ",attr(rmda$confusion,"error"),"\n") ypred <- predict(rmda,newdata=lesData,type="class") ypredMeta <- as.integer(ypred) - 1 ypredQt <- predict(rmda,newdata=lesData,type="posterior") diUnif <- discordance(score1=metavir,score2=ypredMeta,matpond=matpUnif,modalites=mm,titre1="Metavir",titre2="FDA",ref=1,nompond="uniforme") diProp <- discordance(score1=metavir,score2=ypredMeta,matpond=matpPond,modalites=mm,titre1="Metavir",titre2="FDA",ref=1,nompond="proportionnelle") tbcg <- round(100*sum(metavir==ypredMeta)/nbind,1) lesF4 <- metavir==4 tbcF4 <- round(100*sum(metavir[lesF4]==ypredMeta[lesF4])/sum(lesF4),1) mauroc <- multiclass.roc(response=metaF,predictor=ypredMeta) mauc <- as.numeric(mauroc$auc) #mr <- data.frame(titrec,ncol(lesData)-1,dev,diUnif,diProp,attr(rmda$confusion,"error"),tbcg,tbcF4,mauc,as.numeric(br[1,4]),as.numeric(br[1,3])) #colnames(mr) <- c("Titre","nbVar","Dev","discUnif","discProp","MisClass","%BC","%BC_F4","mAUROC","rsmax","rpmax") mr <- data.frame(titrec,ncol(lesData)-1,dev,diUnif,diProp,attr(rmda$confusion,"error"),tbcg,tbcF4,mauc,as.numeric(br[1,4]), as.numeric(br[1,3]),lesVariables(lesData[,-1],8)) colnames(mr) <- c("Titre","nbVar","Dev","discUnif","discProp","MisClass","%BC","%BC_F4","mAUROC","rsmax","rpmax","Variables") row.names(mr) <- 1:nrow(mr) dmc <- mr if (idm==1) { dm <- dmc } else { dm <- rbind(dm,dmc) } # fin si # si bestModel est non nul, on conserve les données et la régression if (idm==bestModel) { bestData <- lesData bestRmda <- rmda bestPredQt <- ypredQt bestPred <- ypredMeta bestDiProp <- diProp } # fin si } # fin pour idm # si maxdec est non nul, on reformate les colonnes d'auroc et de discordance if (maxdec>0) { fmt <- paste(" %0.",maxdec,"f",sep="") for (idc in 3:10) { dm[,idc] <- sprintf(fmt,dm[,idc]) } # fin pour } # fin si print(ddm,quote=FALSE) catn() print(dm,quote=FALSE,right=FALSE) catn() # si bestModel est non nul, analyse du meilleur modèle (a posteriori) if (bestModel>0) { nomBest <- paste(ddm[bestModel,1]," (disc. prop = ",sprintf("%0.3f",bestDiProp),")",sep="") leTitre <- paste("Meilleur modèle FDA = numéro",bestModel,"soit",nomBest) cats(leTitre) cat("ses variables sont : \n") cat(lesVariables(bestData),"\n") matMeta <- matrix(data=0:4,nrow=nrow(bestPredQt),ncol=ncol(bestPredQt),byrow=TRUE) bestPredQtVal <- rowSums(bestPredQt*matMeta) compareScoresMetavir(valMeta=metavir,predMeta=bestPredQtVal,titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsQt) compareScoresMetavir(valMeta=metavir,predMeta=bestPred,titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsMeta) compareScoresMetavir(valMeta=metavir,predMeta=bestPred,titre=nomBest,pointilles="dotted",barres=barresPred,points=FALSE) confusionMatrix(reference=metavir,data=bestPred) } # fin si } # fin de fonction modelesFDAMetavir ################################################################# modelesCLMMetavir <- function(titre,facteurMeta,df,vectChaines,base="",maxdec=0,bestModel=0,pointsMeta=TRUE,barresPred=TRUE) { ################################################################# library(ordinal) # pour la fonction clm() library(pROC) # pour multiclass.roc() # produit de "jolis" tableaux résumés de plusieurs CLM pour les mêmes données # exemple : modelesMDAMetavir(titre="Malah",df=ma,vectChaines=vdc,base="RLI-METAVIR",maxdec=3) # où vdc contient c( "x y", "x u v ", ...) pour choisir les variables # x en col. 1 est la qt réponse et les autres col sont les autres qt # noms des modèles et des variables mm <- modalitesMetavir() matpUnif <- matPen(taille=5,opt="unif") matpPond <- matPen(taille=5,opt="pond") tc <- paste("Modèles CLM pour ",titre,sep="") cats(tc) nbm <- length(vectChaines) ddm <- matrix(nrow=nbm,ncol=3) colnames(ddm) <- c("Data","nbVar","Variables") pdm <- 1:nbm row.names(ddm) <- pdm metavir <- as.integer(facteurMeta ) - 1 metaF <- as.integer(facteurMeta ) - 1 ddm[,1] <- paste(base,pdm,sep="") for (idm in pdm) { titrec <- ddm[idm,1] ndv <- vectChaines[idm] if (ndv==".") { lesData <- df } else { lesData <- df[,chaineEnListe(ndv)] } # fin si ddm[idm,2] <- sprintf("%3d",ncol(lesData)) ddm[idm,3] <- lesVariables(df=lesData,lng=7,maxVar=8) # description modèle CLM metavirFacteur <- as.factor(facteurMeta) lesData2 <- data.frame(cbind(metavirFacteur,lesData)) nbind <- length(metavirFacteur) rclm <- clm(formula=metavirFacteur ~ . ,data=lesData2) srclm <- summary(rclm) br <- bestCor(lesData) cat("modèle ",idm," soit ",ddm[idm,1]," best cor = ",br[1,],"\n") ypredMeta <- as.integer(predict(rclm,data=lesData2,type="class")[[1]]) - 1 diUnif <- discordance(score1=metavir,score2=ypredMeta,matpond=matpUnif,modalites=mm,titre1="Metavir",titre2="CLM",ref=1,nompond="uniforme") diProp <- discordance(score1=metavir,score2=ypredMeta,matpond=matpPond,modalites=mm,titre1="Metavir",titre2="CLM",ref=1,nompond="proportionnelle") tbcg <- round(100*sum(metavir==ypredMeta)/nbind,1) lesF4 <- metavir==4 tbcF4 <- round(100*sum(metavir[lesF4]==ypredMeta[lesF4])/sum(lesF4),1) mauroc <- multiclass.roc(response=metaF,predictor=ypredMeta) mauc <- as.numeric(mauroc$auc) mr <- data.frame(titrec,ncol(lesData),AIC(rclm),diUnif,diProp,tbcg,tbcF4,mauc,as.numeric(br[1,4]),as.numeric(br[1,3]),lesVariables(lesData,8)) colnames(mr) <- c("Titre","nbVar","AIC","discUnif","discProp","%BC","%BC_F4","mAUROC","rsmax","rpmax","Vars") row.names(mr) <- 1:nrow(mr) dmc <- mr if (idm==1) { dm <- dmc } else { dm <- rbind(dm,dmc) } # fin si # si bestModel est non nul, on conserve les données et la régression if (idm==bestModel) { bestData <- lesData bestRclm <- rclm bestPred <- ypredMeta bestDiProp <- diProp } # fin si } # fin pour idm # si maxdec est non nul, on reformate les colonnes d'auroc et de discordance if (maxdec>0) { fmt <- paste(" %0.",maxdec,"f",sep="") for (idc in 3:10) { dm[,idc] <- sprintf(fmt,dm[,idc]) } # fin pour } # fin si print(ddm,quote=FALSE) catn() print(dm,quote=FALSE,right=FALSE) catn() # si bestModel est non nul, analyse du meilleur modèle (a posteriori) if (bestModel>0) { nomBest <- paste(ddm[bestModel,1]," (disc. prop = ",sprintf("%0.3f",bestDiProp),")",sep="") leTitre <- paste("Meilleur modèle CLM = numéro",bestModel,"soit",nomBest) cats(leTitre) cat("ses variables sont : \n") cat(lesVariables(bestData),"\n") compareScoresMetavir(valMeta=metavir,predMeta=bestPred,titre=nomBest,pointilles="dotted",barres=FALSE, points=pointsMeta) compareScoresMetavir(valMeta=metavir,predMeta=bestPred,titre=nomBest,pointilles="dotted",barres=barresPred,points=FALSE) confusionMatrix(reference=metavir,data=bestPred) } # fin si } # fin de fonction modelesCLMMetavir ################################################################# rlo_ord <- function(df,mod="CUM") { ################################################################# # un simple alias pour regressionLogistiqueOrdinale() regressionLogistiqueOrdinale(df,mod) } # fin de fonction rlo_ord ################################################################# regressionLogistiqueOrdinale <- function(df) { ################################################################# # la variable à modéliser doit être en colonne 1, # seules les prédicteurs actifs doivent être présents # implémentation d'un test de likelihood ratio # LR test de proportional odds (hosmer lemeshow, page 304) # ceci doit être en gros équivalent au # Score Test for the Proportional Odds Assumption de SAS # on compare les loglik du modèle paralléle et du modèle non parallèle # via MASS::anova library(MASS) ql <- as.factor(df[,1]) ql <<- as.factor(df[,1]) dfnoql <- df[,-1] dfnoql <<- df[,-1] #rlogiordg <- polr( as.factor(df[,1]) ~ .,data=df[,-1]) rlogiordg <- polr( ql ~ . ,data=dfnoql ) print(rlogiordg) print(summary(rlogiordg)) rlogiordc <- polr( ql ~ 1,data=dfnoql) print(rlogiordc) print(summary(rlogiordc)) anova(rlogiordg,rlogiordc) return(invisible(rlogiordg)) } # fin de fonction regressionLogistiqueOrdinale ################################################################# regressionLogistiqueOrdinale2 <- function(df,mod="CUM") { ################################################################# # mod est "CUM" ou "ADJ" ou "CR" # la variable à modéliser doit être en colonne 1, # seules les prédicteurs actifs doivent être présents # implémentation d'un test de lilelihood ratio # LR test de proportional odds (hosmer lemeshow, page 304) # ceci doit être en gros équivalent au # Score Test for the Proportional Odds Assumption de SAS # on compare les loglik du modèle paralléle et du modèle non parallèle # library(VGAM,warn.conflicts=FALSE) ql <- df[,1] nbvpr <- ncol(df)-1 table(ql) nbcol <- ncol(df) if (mod=="ADJ") { rlo_par <- vglm( ql ~ . , data=df, family=acat(reverse=FALSE,parallel=TRUE) ) } ; # fin si if (mod=="CUM") { rlo_par <- vglm( ql ~ . , data=df, family=cumulative(reverse=FALSE,parallel=TRUE) ) } ; # fin si if (mod=="CR") { rlo_par <- vglm( ql ~ . , data=df, family=cratio(reverse=FALSE,parallel=TRUE) ) } ; # fin si cat(" ll_par (constrained) ",sprintf("%.3f",rlo_par)," -2 Log L (g) ",round(-2*rlo_par,3),"\n") detach(package:VGAM) # ------------------------------------------------------------------- library(rms) cats("# avec rms") ddist <- datadist(df[,-1]) options(datadist="ddist") rlo_par <- lrm( ql ~ .,data=df) summary(rlo_par) detach(package:rms) # ------------------------------------------------------------------- library(MASS) rlogiordg <- polr( as.factor(ql) ~ .,data=df) rlogiordg summary(rlogiordg) rlogiordc <- polr( as.factor(ql) ~ 1,data=df) rlogiordc summary(rlogiordc) anova(rlogiordg,rlogiordc) } # fin de fonction regressionLogistiqueOrdinale2 ################################################################# couleursMetavir <- function() { ################################################################# return(c("blue","green","yellow","orange","red")) } # fin de fonction couleursMetavir ################################################################# modalitesMetavir <- function(maju="maju") { ################################################################# if (maju=="maju") { return(c("F0","F1","F2","F3","F4")) } else { return(c("f0","f1","f2","f3","f4")) } # fin si } # fin de fonction modalitesMetavir ################################################################# matId <- function(taille) { # matrice identité ################################################################# if (missing(taille)) { cat("syntaxe matId(taille) \n") return() } # fin si matrice <- matrix(nrow=taille,ncol=taille) pdv <- 1:taille for (idl in pdv) { for (jdc in pdv) { if (idl==jdc) { matrice[idl,jdc] <- 1 } else { matrice[idl,jdc] <- 0 } # finsi } # fin pour jdc } # fin pour idl rownames(matrice) <- paste("L",sprintf("%02d",pdv),sep="") colnames(matrice) <- paste("C",sprintf("%02d",pdv),sep="") return(matrice) } # fin de fonction matId ################################################################# matPen <- function(taille,opt="unif",noms="") { # matrice de pénalités ################################################################# # opt="unif" : 1 pour toute différence # opt="pond" : |i-j| pour la différence entre i et j if (missing(taille)) { cat("syntaxe : matPen(taille,opt=\"unif\",noms=\"\")\n") cat(" option est unif ou pond \n") return(c()) } # fin si if (!((opt=="unif") | (opt=="pond"))) { cat("invalid option, opt should be \"unif\" or \"pond\" \n") return(c()) } # fin si matrice <- matrix(nrow=taille,ncol=taille) pdv <- 1:taille for (idl in pdv) { for (jdc in pdv) { if (idl==jdc) { matrice[idl,jdc] <- 0 } else { if (opt=="unif") { matrice[idl,jdc] <- 1 } if (opt=="pond") { matrice[idl,jdc] <- abs(idl-jdc) } } # finsi } # fin pour jdc } # fin pour idl if (length(noms)==1) { if (noms=="") { rownames(matrice) <- paste("L",sprintf("%02d",pdv),sep="") colnames(matrice) <- paste("C",sprintf("%02d",pdv),sep="") } # fin si } else { rownames(matrice) <- noms colnames(matrice) <- noms } # finsi return(matrice) } # fin de fonction matPen ################################################################# discordance <- function(score1,score2,matpond,modalites,titre1="score1",titre2="score2",details=TRUE,ref=0,nompond="") { ################################################################# # s'utilise principalement avec score1=METAVIR et score2=prédiction dims <- dim(matpond) nblig <- dims[1] nbcol <- dims[2] matdisc <- matrix(nrow=nblig,ncol=nbcol) pdvl <- 1:nblig pdvc <- 1:nbcol nbv <- length(score1) row.names(matdisc) <- modalites colnames(matdisc) <- modalites # initialisation de la matrice de discordance for (idl in pdvl) { for (jdc in pdvc) { matdisc[idl,jdc] <- 0 } # fin pour jdc } # fin pour idl # remplissage de la matrice de discordance for (idv in (1:nbv)) { idl <- 1 + score1[idv] jdc <- 1 + score2[idv] matdisc[idl,jdc] <- matdisc[idl,jdc] + 1 } # fin pour idv # calcul du score de discordance som <- 0 for (idl in pdvl) { for (jdc in pdvc) { som <- som + matdisc[idl,jdc]*matpond[idl,jdc] } # fin pour jdc } # fin pour idl scordisc <- som/nbv if (details) { catn() if (nompond=="") { cat("Matrice de pondération\n") } else { cat("Matrice de pondération",nompond,"\n") } # fin si print(matpond) if (ref>0) { catn() if (ref==1) { titreR <- titre1 scoreR <- score1 titreP <- titre2 scoreP <- score2 } else { titreR <- titre2 scoreR <- score2 titreP <- titre1 scoreP <- score1 } # fin si cat("Fréquences initiales de référence = ",titreR,"\n") freqref <- factor(scoreR,labels=modalites) print(table(freqref)) cat("Fréquences correspondantes calculées =",titreP,"\n") print(diag(matdisc)) } # fin si catn() cat("Matrice de discordance \n") print(addmargins(matdisc)) catn() cat(titre1,"vs",titre2," ") if (nompond=="") { cat("score moyen de discordance ") } else { cat("score moyen de discordance ",nompond) } # fin si cat(sprintf("%6.3f",scordisc,3)," (",scordisc,") ; ",sep="") bc <- sum(diag(matdisc)) pt <- sum(matdisc) pct <- 100*bc/pt cat(bc," bien classés sur",pt," soit % BC = ",round(pct,1)) catn() } # fin si return(scordisc) } # fin de fonction discordance ################################################################# compareScoresMetavir <- function(valMeta,predMeta,titre="",pointilles="",points=TRUE,barres=FALSE,modalites=modalitesMetavir(),cexm=2) { ################################################################# # comparaison des valeurs METAVIR (=scores de référence) avec les scores prédits : # visualisation des valeurs originales et prédites # pointilles="dashed" ou "dotted" sont valides # graphique standard en points par score Metavir coulmeta <- couleursMetavir() nbi <- length(valMeta) if (points) { idi <- 1:nbi idx <- order(valMeta+idi/10000) xlab_txt <- paste("Etude de ",nbi,"individus (en noir)") plot(idi,valMeta[idx],type="p",main=titre,cex=0.5,ylab="Valeurs prédites (en couleur)",xlab=xlab_txt,ylim=c(-0.5,4.5),cex.main=cexm,cex.lab=cexm) couleursPred <- recadrage(predMeta,0,4,rounding=TRUE) # avant cm <- coulmeta[1+predMeta[idx]] cm <- coulmeta[1+couleursPred[idx]] points(idi,predMeta[idx],col="black",pch=21,bg=cm) ct <- cumsum(table(valMeta)) for (idc in ct[-length(ct)]) { abline(v=idc) } # fin pour if (pointilles!="") { for (idc in 0.5+(0:3)) { abline(h=idc,lty=pointilles) } # fin pour } # fin si text(x= milieux(c(0,ct)),y=-0.5,labels=modalites,cex=2) } # fin si # graphique alternatif ou complémentaire en barres if (barres) { newY <- recadrage(v=predMeta) # 2018 valMeta <- factor(valMeta,levels=0:4) newYm <- factor(newY,levels=0:4) # 2018 tdc <- apply(table(valMeta,newYm),MARGIN=2,FUN=function(x) { 100*x/sum(x) } ) sub_txt <- paste("Prédictions METAVIR en % par stade pour",nbi,"individus") barplot(tdc, beside=FALSE,col=coulmeta,sub=sub_txt,main=titre,cex.main=cexm,cex.sub=cexm) } # fin si } # fin de fonction compareScoresMetavir modalitesFL <- function() { return( c("FL=1","FL=2","FL=3") ) } couleursFL <- function() { return( c("blue","green","red") ) } ################################################################# compareScoresFL <- function(valFL,predFL,titre="",pointilles="",points=TRUE,barres=FALSE,modalites=modalitesFL(),cexm=2,...) { ################################################################# # comparaison des valeurs FL (=scores de référence) avec les scores prédits : # visualisation des valeurs originales et prédites # pointilles="dashed" ou "dotted" sont valides # graphique standard en points par valeur FL coulFL <- couleursFL() nbi <- length(valFL) if (points) { idi <- 1:nbi idx <- order(as.numeric(valFL)+idi/10000) xlab_txt <- paste("Etude de ",nbi,"individus (en noir)") plot(idi,valFL[idx],type="p",main=titre,ylab="Valeurs prédites (en couleur)",xlab=xlab_txt,ylim=c(0,3.5),cex.main=cexm,cex.lab=cexm,cex=0.5) couleursPred <- recadrage(predFL,1,3,rounding=TRUE) # vant cm <- coulmeta[1+predMeta[idx]] cm <- coulFL[couleursPred[idx]] points(idi,predFL[idx],col="black",pch=21,bg=cm,...) ct <- cumsum(table(valFL)) for (idc in ct[-length(ct)]) { abline(v=idc) } # fin pour if (pointilles!="") { for (idc in 0.5+(1:2)) { abline(h=idc,lty=pointilles) } # fin pour } # fin si text(x= milieux(c(0,ct)),y=0.5,labels=modalites,cex=2) } # fin si # graphique alternatif ou complémentaire en barres if (barres) { newY <- recadrage(v=predFL) tdc <- apply(table(valFL,newY),MARGIN=2,FUN=function(x) { 100*x/sum(x) } ) sub_txt <- paste("Prédictions FL en % par stade pour",nbi,"individus") barplot(tdc, beside=FALSE,col=coulFL,sub=sub_txt,main=titre,cex.main=cexm,cex.sub=cexm) } # fin si } # fin de fonction compareScoresFL ################################################################# compareScoresBinaires <- function(valBin1,valBin2,titre="",modalites=c("0","1"),coul=c("green","red"),details=TRUE,graphique=FALSE,fichier="",eps=FALSE,cexm=2) { ################################################################# library("caret") # pour confusionMatrix # comparaison des valeurs binaires de valBin1 (= score de référence) avec les scores prédits dans valBin2 : # visualisation des valeurs originales et prédites en pourcentages par barre #cat("data") if (is.factor(valBin1)) { valBin1 <- as.numeric(valBin1) - 1 } if (details) { extrait(cbind(valBin1,valBin2)) } if (details) { cat("\n",titre,"\n",sep="") } mp <- matPen(2,opt="unif") di <- discordance(score1=valBin1,score2=valBin2,matpond=mp,modalites=modalites,ref=1,details=details) nbi <- length(valBin1) bc <- sum(valBin1==valBin2) tbc <- 100*bc/nbi if (details) { cat(" taux des ",bc,"bien classés sur",nbi,": ",tbc,"\n") } nbi0 <- sum(valBin1==0) bc0 <- sum( (valBin1==valBin2) & (valBin1==0) ) tbc0 <- 100*bc0/nbi0 if (details) { cat(" taux des ",bc0,"bien classés sur",nbi0,"pour la modalité 0 : ",tbc0,"\n") } nd <- bc0 # vrais négatifs TN nc <- nbi0 - bc0 # faux négatifs FN nbi1 <- sum(valBin1==1) bc1 <- sum( (valBin1==valBin2) & (valBin1==1) ) tbc1 <- 100*bc1/nbi1 if (details) { cat(" taux des ",bc1,"bien classés sur",nbi1,"pour la modalité 1 : ",tbc1,"\n") } na <- bc1 # vrais positifs TP nb <- nbi1 - bc1 # faux positifs FP di <- discordance(score1=valBin1,score2=valBin2,matpond=mp,modalites=modalites,ref=1,details=details) lt1 <- length(table(valBin1)) lt2 <- length(table(valBin2)) if (lt1==lt2) { # cat("confusionMatrix dans compareScoresBinaires\n") confusionMatrix(as.factor(valBin1),as.factor(valBin2),positive="1") } else { cat("\nPB : on a ",lt1,"modalités pour valBin1 et ",lt2,"modalités pour valBin2\n") print(table(valBin1,valBin2,useNA="always")) } # fin si # graphique en barres éventuel if (graphique) { if (fichier!="") { if (eps) { postscript(fichier) } else { gr(fichier) } # fin si } # fin si tdc <- apply(table(valBin1,valBin2),MARGIN=2,FUN=function(x) { 100*x/sum(x) } ) sub_txt <- paste("Prédictions en % par stade de référence pour",nbi,"individus") barplot(tdc, beside=FALSE,col=coul,sub=sub_txt,main=titre,ylim=c(0,120),cex.main=cexm,cex.sub=cexm) #barplot(tdc, beside=FALSE,col=coul,main=titre,ylim=c(0,120)) if (fichier!="") { dev.off() cat("vous pouvez utiliser ",fichier,"\n") } # fin si } # fin si se <- na / (na + nc) sp <- nd / (nb + nd) iy <- se + sp - 1 return(c(discordance=di,overall=tbc,tp=na,fp=nb,fn=nc,tn=nd,sens=se,spec=sp,youden=iy)) } # fin de fonction compareScoresBinaires ################################################################# milieux <- function(v) { ################################################################# # renvoie les milieux consécutifs de v1 v2 v3 v4 # soit milieu(v1,v2) milieu(v2,v3)... return( 0.5*(v[-length(v)] + v[-1]) ) } # fin de fonction milieux ################################################################# aurocQlPred <- function(qlb,qt,ci=FALSE) { ################################################################# library(ROCR) # calcul standard vqlb <- qlb vvqt <- qt fltqb <- !is.na(qlb) vqlb <- qlb[ fltqb ] vvqt <- qt[ fltqb ] fltqt <- !is.na(qt) vvqt <- qt[ fltqt ] vqlb <- qlb[ fltqt ] vauroc <- performance(prediction(vvqt,vqlb),"auc")@y.values[[1]] if (ci) { library(pROC) # calcul avec intervalle de confiance vauroc <- ci.auc( roc(response=as.factor(qlb),predictor=qt) ) # print(vauroc) # library(DiagnosisMed) # calcul avec intervalle de confiance #vroc <- ROC(gold=qlb,test=qt) #vauroc <- vroc$AUC.summary } # fin si return(vauroc) } # fin de fonction aurocQlPred ################################################################# auroc <- function(dataFrame,nomCible=NULL,lesVars=NULL,print=TRUE) { ################################################################# # calcule l'auroc pour la cible sur les variables fournies # par défaut : cible = colonne 1, prédicteurs = les autres colonnes library(ROCR) # # library(DiagnosisMed) # non disponible pour R > 3.0 if (is.null(nomCible)) { nomCible <- colnames(dataFrame)[1] } if (is.null(lesVars)) { lesVars <- colnames(dataFrame)[-1] } qlc <- dataFrame[,nomCible] dfc <- dataFrame[,lesVars,drop=FALSE] rlbc <- glm(qlc ~ .,data=dfc,family="binomial") ypr <- predict(rlbc,newdata=dfc,type="response") vau <- aurocQlPred(qlc,ypr,ci=TRUE) if (print) { cat("Auroc : ",vau,"\n") } return( vau ) } # fin de fonction auroc #################################################################### aurocs <- function(dataFrame,nomCible,nomVars,decorrel=0) { #################################################################### # produit les aurocs par ordre décroissant lesVars <- c(nomCible,nomVars) mres <- rchModeleLogistique(dataFrame[,lesVars]) nbvar <- length(nomVars) pdv <- 2:(nbvar+1) row.names(mres)[pdv] <- nomVars mrvar <- as.data.frame(mres[pdv,]) idx <- order(mrvar$AUROC,decreasing=TRUE) mm <- mrvar[idx,"AUROC",drop=FALSE] nmr <- matrix(nrow=nbvar,ncol=1) nmr[,1] <- as.numeric(sprintf("%0.4f ",mm[,1])) row.names(nmr) <- row.names(mm) colnames(nmr) <- c("AUROC") dfc <- dataFrame[,lesVars] qlc <- dataFrame[,nomCible] rlbc <- glm(qlc ~ .,data=dfc[,-1],family="binomial") ypr <- predict(rlbc,newdata=dfc,type="response") amc <- aurocQlPred(dataFrame[,nomCible],ypr) cat("Auroc du modèle complet : ",amc," en dimension ",dims(dataFrame),"\n") if (decorrel==0) { return( nmr ) } # finsi print("Variables par AUROC décroissante") print(nmr) cats(paste("Eliminaton des variables corrélées à plus de ",decorrel)) nnmr <- cbind((1:nrow(nmr)),nmr) nbv <- nrow(nnmr) # nombre de variables vag <- 1 # variables à garder for (idv in (2:nbv)) { ok <- 1 jvar <- 1 nvari <- row.names(nmr)[idv] vari <- dataFrame[,nvari] while (jvar<idv) { if (nnmr[jvar,1]>0) { # on ne compare qu'avec celles non enlevées nvarj <- row.names(nmr)[jvar] varj <- dataFrame[,nvarj] cdc <- cor(vari,varj) if (abs(cdc)>decorrel) { cat(" ",nvari," non retenue car corrélée avec ",nvarj," cor = ",round(cdc,3),"\n") jvar <- nbv + 1 ok <- 0 } # finsi } # fin si jvar <-jvar + 1 } # fin tant que if (ok==0) { nnmr[idv,1] <- (-1)*idv } # fin si } # fin pour idv flt <- nnmr[,1]>0 nnmr <- nnmr[flt,] cat("\nVariables non corrélées par AUROC décroissante\n") print(nnmr) colNoCor <- row.names(nnmr) dataNoCor <- dataFrame[,colNoCor] cat("\n data sans corrélation ",dims( dataNoCor) ,"\n") cat("\n corrélation maximale restante ",maxMatCor( cor(dataNoCor) )[[1]] ,"\n") # on renvoie les variables à conserver return( colNoCor ) } # fin de fonction aurocs #################################################################### aurocs_delong <- function(dataFrame,fichierCSV="",en_matrice=FALSE,aurocs=FALSE,printmat=TRUE) { #################################################################### # produit une matrice des comparaisons deux à deux des aurocs # sur une meme cible en colonne 1 # par défaut, matrice triangulaire supérieure, sauf si en_matrice=TRUE # auquel cas on renvoie toute la matrice # si fichierCSV est non nul, on y écrit les résultats library(Daim) # library(pROC) nbc <- ncol(dataFrame) pdv <- 2:nbc valb <- dataFrame[,1] nb0 <- sum(valb==0) nb1 <- sum(valb==1) cat("Variable binaire : ",nb0," fois la valeur 0 et ",nb1," fois la valeur 1\n\n") cat("Overall test: ") cat( deLong.test(x=dataFrame[,pdv],labels=dataFrame[,1],labpos="1")$global.p ) cat(" (bilateral)\n\n") matauroc <- matrix(NA,nrow=1,ncol=nbc-1) matres <- matrix(NA,nrow=nbc-1,ncol=nbc-1) row.names(matres) <- names(dataFrame)[-1] row.names(matauroc) <- "" colnames(matauroc) <- names(dataFrame)[-1] colnames(matres) <- names(dataFrame)[-1] for (idc in pdv) { if (class(dataFrame[,idc])=="character") { dataFrame[,idc] <- as.numeric(dataFrame[,idc]) } matauroc[1,(idc-1)] <- aurocQlPred(valb,dataFrame[,idc]) for (jdc in (idc:nbc)) { if (jdc==idc) { matres[(idc-1),(jdc-1)] <- (-1) } else { #rocj <- roc(valb,dataFrame[,jdc]) # si : library(pROC) #matres[(idc-1),(jdc-1)] <- roc.test(roci,rocj,method="delong")$p.value matres[(idc-1),(jdc-1)] <- deLong.test(x=dataFrame[,c(idc,jdc)],labels=dataFrame[,1],labpos="1")$global.p if (en_matrice) { matres[(jdc-1),(idc-1)] <- matres[(idc-1),(jdc-1)] } # fin si } # fin si } # fin pour idc } # fin pour idc if (aurocs) { cat("AUROCS\n") print(matauroc) cat("\n") } # fin si if (printmat) { print(matres) cat("\n") } # fin si mdf <- data.frame(test=row.names(matres),matres,stringsAsFactors=FALSE) mdf[ mdf==-1 ] <- "-" mdf[ is.na(mdf) ] <- "" row.names(matres) <- NULL if (fichierCSV!="") { write.table(mdf,file=fichierCSV,sep=";",row.names=FALSE) } # fin si return(invisible(mdf)) } # fin de fonction aurocs_delong ################################################################# coefficientsRLB <- function(dataRlb,valFlt=0.05) { ################################################################# # calcule et renvoie les coefficients de le RLB avec leur intervalle de confiance # valFlt permet de filtrer les variables affichées colnames(dataRlb)[1] <- "ql" rlb <- glm( ql ~ .,data=dataRlb,family="binomial") mintr <- confint(rlb) mcoef <- summary(rlb)$coefficients rescoef <- cbind(mintr[,1],mcoef[,1],mintr[,2],mcoef[,-1]) colnames(rescoef) <- c("Lower","Coefficient","Upper","Std. error","z-value","Prob") idx <- order(rescoef[,"Prob"]) rescoef2 <- rescoef[idx,] flt <- rescoef2[,"Prob"] <= valFlt return(rescoef2[flt,drop=FALSE]) } # fin de fonction coefficientsRLB ################################################################# sensSpec <- function(qlb,qt,details=TRUE) { ################################################################# library(hash) sco <- qt fcs <- qlb ### ligneDesc("VP","vrais positifs","IO","a priori") ; ### ligneDesc("FP","faux positifs" ,"OA","OA max") ; ### ligneDesc("FN","faux négatifs" ,"IP","VPP max") ; ### ligneDesc("VN","vrais négatifs" ,"IN","VPN max") ; ### ligneDesc("VPP","valeur prédictive positive" ,"IY","YOUDEN max") ; ### ligneDesc("VPN","valeur prédictive négative" ,"","") ; ### ligneDesc("YOUDEN","indice J de Youden" ,"","") ; ### # boucle de variation du seuil ("cut-off") pour déterminer les valeurs diagnostiques ### ### # on ne passe en revue que les seuils rencontrés ### fseuils <- hash() ; ### # on met systématiquement 0, 0.5 et 1 comme seuils fseuils[["0.0000"]] = 1 ; fseuils[["0.5000"]] = 1 ; fseuils[["1.0000"]] = 1 ; nbseuils <- 3 ; # nombre de seuils différents nbld <- length(sco) pdl <- 1:nbld for (idl in pdl) { vdd = sprintf("%07.4f",sco[idl]) ; if (has.key(vdd,fseuils)) { fseuils[[vdd]] <- fseuils[[vdd]] + 1 } else { fseuils[[vdd]] <- 1 ; nbseuils <- nbseuils + 1 } ; # fin si } ; # fin pour vseuils <- sort(as.numeric(keys(fseuils))) nbseuilsmax <- 200 ; xdata <- vector() ; ydata <- vector() ; # première boucle : on calcule les valeurs max au passage seuil <- 0.0 ; pas <- 0.01 ; ym <- -1 ; # pour youden max im <- 0 ; cm <- -1 ; sm <- -1 ; sp <- -1 ; # valeurs pour seuils max vsio <- 0.5 ; vsoa <- 0 ; vcoa = 0 ; vsip <- 0 ; vcip = 0 ; vsin <- 0 ; vcin = 0 ; vsiy <- 0 ; idsvpp0p9 <- 0 idsvpn0p9 <- 0 lstx <- "" ; lsty <- "" ; lstx2 <- "" ; lsty2 <- "" ; # tableaux de stockage ts_na <- vector() ; ts_nb <- vector() ; ts_nc <- vector() ; ts_nd <- vector() ; ts_spec <- vector() ; ts_sens <- vector() ; ts_vpp <- vector() ; ts_vpn <- vector() ; ts_you <- vector() ; ts_ova = array() ; ## while (seuil<=1.001) { iseuil <- 1 ; while (iseuil <= nbseuils) { seuil <- vseuils[iseuil] ; ### ### # comptage des biens et mal classés ### # nbl est le nombre de données ### # en idl, sco[idl] est la valeur de la QT et fcs[idl] la valeur de la QL ### # pour savoir si on vaut 0 ou 1 on utilise la variable seuil ### na <- 0 ; # bien classés positifs = vrais positifs nb <- 0 ; # faux positifs nc <- 0 ; # faux négatifs nd <- 0 ; # bien classés négatifs = vrais négatifs ### ### for (idl in pdl) { vdd <- sco[idl] ; vfc <- fcs[idl] ; #cat(" idl ",idl," vdd ",vdd," vfc ",vfc," seuil ",seuil," \n") if (vdd<=seuil) { vda <- 0 ; } else { vda <- 1 ; } ; if ((vfc==1) & (vda==1)) { na <- na + 1 ; } ; if ((vfc==0) & (vda==1)) { nb <- nb + 1 ; } ; if ((vfc==1) & (vda==0)) { nc <- nc + 1 ; } ; if ((vfc==0) & (vda==0)) { nd <- nd + 1 ; } ; } ; # fin pour if ((na+nc)==0) { sensi <- 0 ; } else { sensi <- na/(na+nc) ; } ; if ((nb+nd)==0) { speci <- 0 ; } else { speci <- nd/(nb+nd) ; } ; if ((na+nb)==0) { vpp <- 1 ; } else { vpp <- na/(na+nb) ; } ; if ((nc+nd)==0) { vpn <- 1 ; } else { vpn <- nd/(nc+nd) ; } ; voa <- (na+nd)/(na+nb+nc+nd) ; you <- sensi + speci -1 ; if (you>ym) { cm <- seuil ; ym <- you ; sm <- sensi ; sp <- speci ; vppm <- vpp ; vpnm <- vpn ; vsiy <- seuil ; } ; # fin de si if ((vpp>vcip) & (na+nb>0) ) { vcip <- vpp ; vsip <- seuil ; } ; if ((vpn>vcin) & (nc+nd>0) ) { vcin <- vpn ; vsin <- seuil ; } ; if (voa>vcoa) { vcoa <- voa ; vsoa <- seuil ; } ; # stockage pour les autres boucles ts_na[iseuil] <- na ; ts_nb[iseuil] <- nb ; ts_nc[iseuil] <- nc ; ts_nd[iseuil] = nd ; ts_spec[iseuil] = speci ; ts_sens[iseuil] = sensi ; ts_vpp[iseuil] = vpp ; ts_vpn[iseuil] = vpn ; ts_you[iseuil] = you ; ts_ova[iseuil] = voa ; iseuil <- iseuil + 1 } ; # fin de tant que ### ### # deuxième boucle : on affiche ### cols <- chaineEnListe("CUTOFF CRIT VP FP FN VN TOTAL SPEC 1-SPEC SENS VPP VPN YOUDEN OA ") ; nbc <- length(cols) tabRes <- matrix(nrow=nbseuils,ncol=nbc) colnames(tabRes) <- cols #cat(" CUTOFF CRIT VP FP FN VN TOTAL SPEC 1-SPEC SENS VPP VPN YOUDEN OA\n") ; iseuil <- 1 ; pseuil <- -1 ; is_iyou <- 0 ; is_iova <- 0 ; is_ivpp <- 0 ; is_ivpn <- 0 ; while (iseuil <= nbseuils) { seuil <- vseuils[iseuil] ; # comptage des biens et mal classés # nbl est le nombre de données # en idl, sco[idl] est la valeur de la QT et fcs[idl] la valeur de la QL # pour savoir si on vaut 0 ou 1 on utilise la variable seuil na <- ts_na[iseuil] ; nb <- ts_nb[iseuil] ; nc <- ts_nc[iseuil] ; nd <- ts_nd[iseuil] ; tabRes[iseuil,"CUTOFF"] <- sprintf("%9.4f",seuil) tabRes[iseuil,"VP"] <- na tabRes[iseuil,"FP"] <- nb tabRes[iseuil,"FN"] <- nc tabRes[iseuil,"VN"] <- nd tabRes[iseuil,"TOTAL"] <- na+nb+nc+nd sensi <- ts_sens[iseuil] ; speci <- ts_spec[iseuil] ; vpp <- ts_vpp[iseuil] ; vpn <- ts_vpn[iseuil] ; you <- ts_you[iseuil] ; ova <- ts_ova[iseuil] ; umspi <- 1 - speci ; #ls <- paste(ls,sprintf("%9.3f",seuil)) cri <- "" ; if ((idsvpp0p9==0) & (vpp>=0.9)) { cri <- "VPP0.9" idsvpp0p9 <- iseuil } # fin si if ((idsvpn0p9==0) & (vpn<=0.9)) { cri <- "VPN0.9" idsvpn0p9 <- iseuil } # fin si if (seuil==vsio) { cri <- "IO " ; } ; if (seuil==vsoa) { cri <- "OA " ; is_ova <- iseuil ; } ; if (seuil==vsip) { cri <- "IP " ; is_vpp <- iseuil ; } ; if (seuil==vsin) { cri <- "IN " ; is_vpn <- iseuil ; } ; if (seuil==vsiy) { cri <- "IY " ; is_you <- iseuil ; } ; #ls <- paste(ls," ",cri) ; tabRes[iseuil,"CRIT"] <- cri #ls <- paste(ls,sprintf("%6d",na),sprintf("%6d",nb),sprintf("%6d",nc),sprintf("%6d",nd)) ; #ls <- paste(ls,sprintf(" %6d ",(na+nb+nc+nd))) ; #ls <- paste(ls,sprintf("%12.7f",speci)) ; #ls <- paste(ls,sprintf("%12.7f",umspi)) ; #ls <- paste(ls,sprintf("%12.7f",sensi)) ; #ls <- paste(ls,sprintf("%12.7f",vpp)) ; #ls <- paste(ls,sprintf("%12.7f",vpn)) ; #ls <- paste(ls,sprintf("%12.7f",you)) ; #ls <- paste(ls,sprintf("%12.7f",ova)) ; #ls <- paste(ls,"\n") ; tabRes[iseuil,"SPEC"] <- sprintf("%11.6f",speci); tabRes[iseuil,"1-SPEC"] <- sprintf("%11.6f",umspi) ; tabRes[iseuil,"SENS"] <- sprintf("%11.6f",sensi) ; tabRes[iseuil,"VPP"] <- sprintf("%11.6f",vpp) ; tabRes[iseuil,"VPN"] <- sprintf("%11.6f",vpn) ; tabRes[iseuil,"YOUDEN"] <- sprintf("%11.6f",you) ; tabRes[iseuil,"OA"] <- sprintf("%11.6f",ova) ; n_seuil <- seuil + 0.0 ; n_pseuil <- pseuil + 0.0 ; #if (n_seuil!=n_pseuil) { cat(ls) ; } ; seuil <- seuil + pas ; pseuil <- seuil ; iseuil <- iseuil + 1 } ; # fin de tant que tabRes <- as.data.frame(tabRes) colnames(tabRes) <- cols if (details) { cat("\nListe des seuils et de leurs caractéristiques \n\n") print(tabRes,row.names=FALSE) } # fin si cat("\nSeuils remarquables parmi les ",nbseuils," seuils vus\n\n") ; tabRes2 <- tabRes[ tabRes[,"CRIT"]!="", ] print(tabRes2,row.names=FALSE) } # fin de fonction sensSpec ################################################################# linCor <- function(x,y,print=TRUE) { ################################################################# # concordance de Lin via epiR library(epiR) cdcl <- epi.ccc(x,y) if (print) { cat(" Concordance de Lin : ",cdcl$rho.c$est,"\n") } return(cdcl$rho.c) } # fin de fonction linCor ################################################################# ################################################################# ## ## fonctions pour les gestion de colonnes binaires nombreuses ## ################################################################# ################################################################# ################################################################# ################################################################# nodup <- function(matdata,noconst=TRUE,noduprow=TRUE,nodupcol=TRUE,file="") { ################################################################# if (missing(matdata)) { cat(" nodup : élimine les colonnes constantes, les lignes égales, les colonnes égales\n\n") cat(" syntaxe : nodup(matdata,noduprow=TRUE,nodupcol=TRUE,file=\"\")) \n\n") } ; # fin si matdataorg <- matdata newmatdata <- matdata # détection et élimination des colonnes constantes if (noconst) { cat("\nColonnes constantes \n") nbcol <- ncol(matdata) nblig <- nrow(matdata) pdvcol <- rev(1:nbcol) pdvlig <- 1:nblig nbconst <- 0 for (icol in pdvcol) { cst <- TRUE pvc <- matdata[1,icol] jlig <- 2 while (jlig<=nblig) { if (matdata[jlig,icol]!=pvc) { jlig <- nblig + 1 cst <- FALSE } ; # finsi jlig <- jlig + 1 } ; # fin tant que if (cst) { cat(" la colonne ",sprintf("%5d",icol)," soit ",names(matdata)[icol]," est éliminée car constante\n") nbconst <- nbconst +1 newmatdata <- newmatdata[,-icol] } # fin pour } # fin pour icol cat(" réduction : ") if (nbconst>0) { if (nbconst==1) { cat(nbconst," colonne constante supprimée \n") } else { cat(nbconst," colonnes constantes supprimées \n") } # fin si } else { cat(" pas de colonnes constantes détectées \n") } # fin si } # fin si colonnes constantes # détection et élimination des colonnes égales matdata <- newmatdata newmatdata <- matdata nbcol <- ncol(matdata) nblig <- nrow(matdata) if (nodupcol) { cat("\nColonnes égales \n") pdvcol1 <- 1:(nbcol-1) colasup <- c() colatester <- rep(TRUE,nbcol) #cat("init ",colatester) for (icol1 in pdvcol1) { jcol <- icol1 + 1 for (icol2 in rev(jcol:nbcol)) { if (colatester[icol2]) { if (sum(matdata[,icol2]==matdata[,icol1])==nblig) { cat(" la colonne ",sprintf("%5d",icol2)," soit ",names(matdata)[icol2]," est éliminée car égale à ") cat("la colonne ",sprintf("%5d",icol1)," soit ",names(matdata)[icol1]," \n") colasup <- c(colasup,icol2) colatester[icol2] <- FALSE #cat("donc ",colatester) } # fin si } # fin si } # fin pour icol2 } # fin pour icol1 cat(" réduction : ") nbcolasup <- length(colasup) if (nbcolasup>0) { colasup <- rev(sort(unique(colasup))) nbcolasup <- length(colasup) if (nbcolasup==1) { cat(nbcolasup," colonne égale supprimée \n") } else { cat(nbcolasup," colonnes égales supprimées \n") } # fin si #print( colasup ) for (jcol in colasup) { newmatdata <- newmatdata[,-jcol] } # fin pour jcol } else { cat(" pas de colonnes égales détectées \n") } # fin si # détection et élimination des colonnes inverses logiques matdata <- newmatdata newmatdata <- matdata nbcol <- ncol(matdata) nblig <- nrow(matdata) cat("\nColonnes inverses logiques \n") pdvcol1 <- 1:(nbcol-1) colasup <- c() for (icol1 in pdvcol1) { jcol <- icol1 + 1 pdvcol2 <- rev(jcol:nbcol) for (icol2 in rev(jcol:nbcol)) { c1 <- matdata[,icol1] c2 <- matdata[,icol2] s1 <- sum(c1==(1-c2)) s2 <- sum(c2==(1-c1)) if ((s1==nblig)|(s2==nblig)) { cat(" la colonne ",sprintf("%5d",icol2)," soit ",names(matdata)[icol2]," est éliminée car inverse logique ") cat("la colonne ",sprintf("%5d",icol1)," soit ",names(matdata)[icol1]," \n") colasup <- c(colasup,icol2) } # fin si } # fin pour icol2 } # fin pour icol1 cat(" réduction : ") nbcolasup <- length(colasup) if (nbcolasup>0) { colasup <- rev(sort(unique(colasup))) nbcolasup <- length(colasup) if (nbcolasup==1) { cat(nbcolasup," colonne inverse logique supprimée \n") } else { cat(nbcolasup," colonnes inverses logiques supprimées \n") } # fin si #print( colasup ) for (jcol in colasup) { newmatdata <- newmatdata[,-jcol] } # fin pour jcol } else { cat(" pas de colonnes inverses logiques détectées \n") } # fin si } # fin si colonnes égales ou inverses # détection et élimination des lignes égales if (noduprow) { cat("\nLignes égales \n") matdata <- newmatdata newmatdata <- matdata nbcol <- ncol(matdata) nblig <- nrow(matdata) pdvlig1 <- 1:(nblig-1) ligasup <- c() for (ilig1 in pdvlig1) { jlig <- ilig1 + 1 for (ilig2 in rev(jlig:nblig)) { if (sum(matdata[ilig2,]==matdata[ilig1,])==nbcol) { cat(" la ligne ",sprintf("%5d",ilig2)," soit ",row.names(matdata)[ilig2]," est éliminée car égale à ") cat("la ligne ",sprintf("%5d",ilig1)," soit ",row.names(matdata)[ilig1]," \n") ligasup <- c(ligasup,ilig2) } # fin si } # fin pour ilig2 } # fin pour ilig1 cat(" réduction : ") nbligasup <- length(ligasup) if (nbligasup>0) { ligasup <- rev(sort(unique(ligasup))) if (nbligasup==1) { cat(nbligasup," lignes égales supprimées \n") } else { cat(nbligasup," lignes égales supprimées \n") } # fin si #print( ligasup ) for (jlig in ligasup) { newmatdata <- newmatdata[-jlig,] } # fin pour jlig } else { cat(" pas de lignes égales détectées \n") } # fin si } # fin si colonnes égales ou inverses # affichage des dimensions avant et après cat("\nRésumé des dimensions\n") cat(" données initiales : ",sprintf("%5d",dim(matdataorg)),"\n") cat(" données finales : ",sprintf("%5d",dim(newmatdata)),"\n\n") if (file!="") { write.table(newmatdata,file=file,quote=FALSE,) cat("les données finales ont été écrites dans le fichier ",file,"\n") } ; # fin si return(newmatdata) } # fin de fonction nodup ################################################################# noconst <- function(matdata,file="") { ################################################################# # un simple raccourci pour les options TRUE FALSE FALSE de nodup return(nodup(matdata,noconst=TRUE,noduprow=FALSE,nodupcol=FALSE,file)) } # fin de fonction noconst ################################################################# anared <- function(matdata,noconst=TRUE,noduprow=TRUE,nodupcol=TRUE,file="") { ################################################################# # un simple raccourci pour les options TRUE TRUE TRUE de nodup return(nodup(matdata,noconst=TRUE,noduprow=TRUE,nodupcol=TRUE,file)) } # fin de fonction anared ################################################################# ################################################################# ################################################################# ## ## fonctions pour l'analyse des données (ACP puis CAH) ## ################################################################# ################################################################# ################################################################# ################################################################# lignePointillesACP <- function(nbvf) { ################################################################# pdvf <- 1:nbvf cat(" +-------+------------+-----------------") for (idf in pdvf) { cat("+------------------") } cat("+\n") } # fin de fonction lignePointillesACP ################################################################# ligneCadreCtrACP <- function() { ################################################################# cat("+--------------+-----------+---------+\n") } # fin de fonction ligneCadreCtrACP ################################################################# acp <- function(titre,matdata,stat=1,nbfac=-1,out=c("ind","var"),bestctr=0,plans=0) { ################################################################# # si stat=0 : pas de stat sur les variables library(FactoMineR) if (missing(titre)) { cat(" syntaxe : acp(titre,matdata,stat=1,nbfac=-1,out=c(\"ind\",\"var\"),bestctr=0,plans=0) \n") return() } # finsi # on produit les sorties de l'ACP comme l'ADDAD, mais aucun graphique nblig <- nrow(matdata) pdl <- 1:nblig nomslig <- row.names(matdata) nbcol <- ncol(matdata) pdc <- 1:nbcol nomscol <- colnames(matdata) cat("\n") cat("ACP du dossier ",titre," dimensions ",nblig,"x",nbcol,"\n\n") #cat(" stat = ",stat,"\n") ; attends() ; if (stat==1) { # statistiques descriptives # 1. Résumé univarié des variables allQT(matdata,"","",FALSE,"",FALSE) # 2. Matrice des ccl mdc(matdata) } ; # fin si sur stat=0 # 3. Valeurs propres et inertie nbfac2 <- nbfac if (nbfac<=0) { nbfac2 <- min(nblig-1,nbcol-1) } # fin si acpres <- PCA(matdata,graph=FALSE,ncp=nbfac2) if (nbfac<=0) { cat("\nHistogramme des valeurs propres\n\n") valp <- acpres$eig nbvp <- nrow(valp) pdvv <- 1:nbvp lnghist <- 60 cat(" +------+--------------+-----------+---------+----------+--------------------------------------------------------------+\n") cat(" | Num | Val. Propre. | Pourcent. | Cumul % | Variat % | Histogramme des valeurs propres |\n") cat(" +------+--------------+-----------+---------+----------+--------------------------------------------------------------+\n") for (idvp in pdvv) { cat(" |",sprintf("%3d " ,idvp)) cat("|" ,sprintf(" %8.5f ",valp[idvp,1])) cat("|" ,sprintf(" %7.3f " ,valp[idvp,2])) cat("|" ,sprintf("%7.3f " ,valp[idvp,3])) if (idvp==1) { dif <- 0 } else { dif <- valp[(idvp-1),2] - valp[idvp,2] } # fin si cat("|",sprintf("%8.3f ",dif)) nbpointil <- round(lnghist*valp[idvp,1]/valp[1,1]) cat("|",copies("*",nbpointil),copies(" ",lnghist-nbpointil)) cat("|\n") } # fin pour idvp cat(" +------+--------------+-----------+---------+----------+--------------------------------------------------------------+\n") # kaiser's criterion : > mean # cattell's scree test : inflection moyinert <- mean(valp[,1]) cat("\n Inertie moyenne : ",sprintf(" %8.5f",moyinert),"\n") ida <- 1 while (valp[ida,1]>moyinert) { ida <- ida + 1 } ; # fin tant que nbax1 <- ida - 1 cat(" Selon le critère de Kaiser, il faudrait retenir ",nbax1," axes car d'inertie supérieure à cette moyenne.\n") mddd <- matrix(nrow=nbvp,ncol=3,NA) colnames(mddd) <- c("Val. Prop.","Diff. rel. 1","Diff. rel. ") row.names(mddd) <- sprintf("%3d",pdvv) nbax2 <- (-1) for (idv in pdvv) { mddd[idv,1] <- valp[idv,1] if (idv>1) { mddd[idv,2] <- mddd[idv-1,1] - mddd[idv,1] } # fin si if (idv>2) { mddd[idv,3] <- mddd[idv-1,2] - mddd[idv,2] } # fin si } # fin pour idp ida <- 3 if (nbfac2>2) { while (mddd[ida,3]>0) { ida <- ida + 1 } ; # fin tant que } ; # fin si nbax2 <- ida - 1 cat(" Selon le critère d'inflexion (Cattell's scree test), il faudrait retenir ",nbax2," axes.\n") } else { # il peut y avoir très peu de colonnes dans une démo nbfac <- min(nbfac,nbcol-1,nblig-1) pdvf <- 1:nbfac # 4. Facteurs, contributions et corrélation if ("var" %in% out) { cat("\nRésultats pour les variables principales\n\n") # il manque pour les variables : QLT POIDS INR et COR pour chaque facteur acpres$var$qlt <- rep(-1,nbcol) acpres$var$poids <- rep(1,nbcol) acpres$var$inr <- rep(1000/nbcol,nbcol) for (icol in pdc) { acpres$var$qlt[icol] <- sum(1000*acpres$var$cos2[icol,(1:nbfac)]) } # fin pour icol # affichages lignePointillesACP(nbfac) cat(" | J1 | IDENTIF | QLT POIDS INR ") for (idf in pdvf) { cat("| F",sprintf("%02d",idf)," COR CTR ",sep="") } cat("| \n") lignePointillesACP(nbfac) for (icol in pdc) { cat(" | ",sprintf("%4d ",icol)) cat("| ",sprintf("%-9s ",substr(nomscol[icol],1,9))) poi <- acpres$var$poids[icol] inr <- acpres$var$inr[icol] qlt <- acpres$var$qlt[icol] cat("| ",sprintf("%4.0f",qlt),sprintf("%4.0f",poi),sprintf("%4.0f ",inr)) for (idf in pdvf) { coordvar <- 1000*acpres$var$coord[icol,idf] correvar <- acpres$var$cor[icol,idf] corr2var <- 1000*correvar*correvar cntrivar <- 10*acpres$var$contrib[icol,idf] cat("| ",sprintf("%5.0f",coordvar),sprintf("%4.0f",corr2var),sprintf("%4.0f ",cntrivar)) } # fin pour idf cat("|\n") } # fin pour icol lignePointillesACP(nbfac) } # fin si "var" %in% out if ("ind" %in% out) { cat("\nRésultats pour les individus principaux \n\n") # il manque pour les individus : QLT POIDS INR et COR pour chaque facteur # somme des inerties absolues des individus inrtot <- 0 for (ilig in pdl) { inrtot <- inrtot + sum(acpres$ind$coord[ilig,(1:nbfac)]**2) } # fin pour ilig acpres$ind$poids <- rep(1000/nblig,nblig) acpres$ind$qlt <- rep(-1,nblig) acpres$ind$inr <- rep(-1,nblig) acpres$ind$cor <- matrix(nrow=nblig,ncol=nbfac,-1) acpres$ind$inrki <- matrix(nrow=nblig,ncol=nbfac,-1) acpres$ind$inrk <- rep(-1,nbfac) for (ilig in pdl) { acpres$ind$qlt[ilig] <- sum(acpres$ind$cos2[ilig,(1:nbfac)]) for (idf in pdvf) { acpres$ind$inrki[ilig,idf] <- acpres$ind$coord[ilig,idf]**2 } # fin pour idf acpres$ind$inr[ilig] <- sum(acpres$ind$coord[ilig,(1:nbfac)]**2)/inrtot } # fin pour icol for (idf in pdvf) { acpres$ind$inrk[idf] <- sum(acpres$ind$inrki[(1:nblig),idf]) } # fin pour idf for (ilig in pdl) { for (idf in pdvf) { # CTR = acpres$ind$cor[ilig,idf] <- acpres$ind$inrki[ilig,idf]/acpres$ind$inrk[idf] acpres$ind$cor[ilig,idf] <- acpres$ind$inrki[ilig,idf]/(inrtot*acpres$ind$inr[ilig]) } # fin pour idf } # fin pour icol # affichages lignePointillesACP(nbfac) cat(" | I1 | IDENTIF | QLT POIDS INR ") for (idf in pdvf) { cat("| F",sprintf("%02d",idf)," COR CTR ",sep="") } cat("| \n") lignePointillesACP(nbfac) for (ilig in pdl) { cat(" | ",sprintf("%4d ",ilig)) cat("| ",sprintf("%-9s ",substr(nomslig[ilig],1,9))) inr <- 1000*acpres$ind$inr[ilig] poi <- acpres$ind$poids[ilig] qlt <- 1000*acpres$ind$qlt[ilig] cat("|",sprintf("%5.0f",qlt),sprintf("%4.0f",poi),sprintf("%4.0f ",inr)) for (idf in pdvf) { coordind <- 1000*acpres$ind$coord[ilig,idf] corr2ind <- 1000*acpres$ind$cor[ilig,idf] cntriind <- 10*acpres$ind$contrib[ilig,idf] cat("| ",sprintf("%5.0f",coordind),sprintf("%4.0f",corr2ind),sprintf("%4.0f ",cntriind)) } # fin pour idf cat("|\n") } # fin pour ilig lignePointillesACP(nbfac) cat("\n") } # fin si "ind" %in% out if (bestctr!=0) { if ("var" %in% out) { vbestctr <- bestctr if (bestctr!=0) { cat("Meilleures contributions par axe pour les variables\n") } # fin si if (bestctr==-1) { vbestctr = 1000 / (nbcol-1) cat(" seuil de contribution fixé à la moyenne ",round(vbestctr),"\n") } else { cat(" seuil de contribution fixé à ",round(vbestctr),"\n") } # fin si for (idf in pdvf) { idmc <- which(10*acpres$var$contrib[,idf]>vbestctr) nbe <- length(idmc) mc <- cbind(10*acpres$var$contrib[idmc,idf],1000*acpres$var$coord[idmc,idf]) nmc <- nomscol[idmc] pde <- 1:nbe ord <- order(mc[,1],decreasing=TRUE) cat("Axe ",idf,"\n") ligneCadreCtrACP() cat("| VARIABLE | COORD | CTR |\n") ligneCadreCtrACP() for (ide in pde) { jde <- ord[ide] cat("| ",sprintf("%-9s ",substr(nmc[jde],1,9))) cat(" | ",sprintf("%5.0f",mc[jde,2])," | ",sprintf("%4.0f ",mc[jde,1])," | \n") } # fin pour icol ligneCadreCtrACP() } # fin pour idf } # fin si "var" %in% out if ("ind" %in% out) { ibestctr <- bestctr if (bestctr!=0) { cat("Meilleures contributions par axe pour les individus\n") } # fin si if (bestctr==-1) { ibestctr = 1000 / (nbcol-1) cat(" seuil de contribution fixé à la moyenne ",round(ibestctr),"\n") } else { cat(" seuil de contribution fixé à ",round(ibestctr),"\n") } # fin si for (idf in pdvf) { idmc <- which(10*acpres$ind$contrib[,idf]>ibestctr) nbe <- length(idmc) cat("Axe ",idf) if (nbe==0) { cat(" aucune CTR importante\n") } else{ cat("\n") mc <- cbind(10*acpres$ind$contrib[idmc,idf],1000*acpres$ind$coord[idmc,idf]) nmc <- nomslig[idmc] pde <- 1:nbe ord <- order(mc[,1],decreasing=TRUE) ligneCadreCtrACP() cat("| INDIVIDU | COORD | CTR |\n") ligneCadreCtrACP() for (ide in pde) { jde <- ord[ide] cat("| ",sprintf("%-9s ",substr(nmc[jde],1,9))) cat(" | ",sprintf("%5.0f",mc[jde,2])," | ",sprintf("%4.0f ",mc[jde,1])," | \n") } # fin pour icol ligneCadreCtrACP() } # fin si } # fin pour idf } # fin si "ind" %in% out } # fin si } ; # fin si sur nbfac > 0 return(invisible(acpres)) } # fin de fonction acp ################################################################# acpLoadings <- function(resacp) { return(sweep( resacp$var$coord,2,sqrt(resacp$eig[1:ncol(resacp$var$coord),1]),FUN="/") ) } # fin de fonction acpLoadings ################################################################# addClassMeans <- function(df) { ################################################################# # le numéro de classe est en colonne 1 # on ajoute les moyennes par classe # en tant qu'individus supplémentaires # exemple d'utilisation : # leaqtMoy <- addClassMeans( leaqt46 ) ################################################################# nbcl <- length(unique(df[,1])) pdvcl <- 1:nbcl nbcol <- ncol(df) ind_sup <- matrix(nrow=nbcl,ncol=nbcol,-1) colnames(ind_sup) <- colnames(df) #nomsclasses <- paste("class ",sprintf("%02d",pdvcl),sep="") nomsclasses <- paste("class ",pdvcl,sep="") rownames(ind_sup) <- nomsclasses for (idc in pdvcl) { flt <- (df[,1]==idc) data <- df[flt,] ind_sup[idc,1] <- idc for (jcol in (1:(nbcol-1))) { ind_sup[idc,1+jcol] <- mean(data[,1+jcol]) } # fin pour } # fin pour dfr <- rbind(df,ind_sup) dfr[,1] <- factor(dfr[,1],levels=pdvcl,labels=nomsclasses) return( dfr ) } # fin de fonction addClassMeans ################################################################# acpFacteur <- function(titre,dataMatrix,facteur,grFile="",listeCouleurs=c("blue","red","green","black","orange"),plan=c(0,0),tp=TRUE) { ################################################################# if (missing(titre)) { cat("acpFacteur : une analyse en composante principale avec modalités coloriées\n") ; cat("syntaxe : acpFacteur(titre,dataMatrix,facteur,grFile) \n") cat("exemples : acpFacteur('demo avec iris data',iris[,1:4],iris[,5])\n") ; cat(" acpFacteur('demo avec iris data',iris[,1:4],iris[,5],plan=c(1,2))\n") ; return() ; } ; # fin de si # chargement des librairies pour PCA library(ade4) # préparation de la liste des couleurs cat("liste des couleurs : ",listeCouleurs,"\n") #listeCouleurs <- c("blue","red","green","black","orange") couleurs <- rep("blue",length(facteur)) moda <- sort(unique(facteur)) nbMod <- length(moda) for (idm in (1:nbMod)) { couleurs[facteur==moda[idm]] <- listeCouleurs[idm] } # fin pour idm # diagrammes de dispersion colorisés #pairs(dataMatrix,col=couleurs,main=titre) # réalisation de l'acp acpData <- dudi.pca(dataMatrix,scannf = FALSE, nf = 5) # on met en forme les valeurs propres # et on trace son histogramme vp <- acpData$eig vp_i <- 1:length(vp) vp_r <- round( 100*vp/sum(vp),0 ) vp_rc <- cumsum(vp_r) dsc_vp <- cbind(vp_i,vp,vp_r,vp_rc) colnames(dsc_vp) <- c("Axe","Valeur propre","Pourcent","Cumul") print(dsc_vp[1:min(9,nrow(dsc_vp)),]) ## barplot(vp_r,col=heat.colors(length(vp_r)),main=titre) # quelques tracés pour mieux comprendre # comment se situent les variables # et les groupes if (!grFile=="") { png(grFile,width=1600,height=1200) } if (identical(plan,c(0,0))) { par(mfrow=c(2,2)) barplot(vp_r,col=heat.colors(length(vp_r)),main=titre) scatter(acpData,clab.row=0,posieig="none",main=paste(titre,"plan 1-2")) s.class(dfxy=acpData$li,fac=facteur,col=listeCouleurs,xax=1,yax=2,add.plot=TRUE) if (tp) title(" Plan 1-2") scatter(acpData,clab.row=0,posieig="none",main=paste(titre,"plan 1-3")) s.class(dfxy=acpData$li,fac=facteur,col=listeCouleurs,xax=1,yax=3,add.plot=TRUE) if (tp) title(" Plan 1-3") scatter(acpData,clab.row=0,posieig="none",main=paste(titre,"plan 2-3")) s.class(dfxy=acpData$li,fac=facteur,col=listeCouleurs,xax=2,yax=3,add.plot=TRUE) if (tp) title(" Plan 2-3") if (!grFile=="") { dev.off() cat ("vous pouvez utiliser ",grFile,"\n") } # fin si par(mfrow=c(1,1)) } else { vx <- plan[1] vy <- plan[2] scatter(acpData,clab.row=0,posieig="none",main=paste(titre,paste("plan ",vx,"-",vy,sep="")),clab.col=FALSE) s.class(dfxy=acpData$li,fac=facteur,col=listeCouleurs,xax=vx,yax=vy,add.plot=TRUE) if (tp) title(paste(" Plan ",vx,"-",vy,sep="")) } # fin si } ; # fin de fonction acpFacteur ################################################################# corCircle <- function(titre,data,seuil=-1,grFile="") { ################################################################# library(FactoMineR) if (!grFile=="") { png(grFile,width=1600,height=1200) } resacp <- PCA(data,graph=FALSE) if (seuil==-1) { graph.var(resacp,axes=c(1,2),choix=c("var"),new.plot=FALSE,title=titre) } else { graph.var(resacp,axes=c(1,2),choix=c("var"),lim.cos2.var=seuil,col.var="grey",new.plot=FALSE,xlim=c(-2,2),ylim=c(-1,1),main="PCA",title="PCA",xaxt="n",yaxt="n",xlab="",ylab="",sub="",ann=FALSE) par(new=TRUE) graph.var(resacp,axes=c(1,2),choix=c("var"),lim.cos2.var=0.4,new.plot=FALSE,xlim=c(-2,2),ylim=c(-1,1),main="",title="",xaxt="n",yaxt="n",xlab="") } # finsi if (!grFile=="") { dev.off() cat ("vous pouvez utiliser ",grFile,"\n") } # fin si } ; # fin de fonction corCircle ################################################################# cadreCah2co <- function() { ################################################################# cat("+--------+-----------+-------+--------+--------+---------------------------------------------+\n") } # fin de fonction cadreCah2co ################################################################# cah2co <- function(titre,coordata,graphique=TRUE,coulCAH="black",vcex=1,vadj=-1) { ################################################################# library(ape) # pour as.phylo if (missing(titre)) { cat("syntaxe : cah2co(titre,coordata)\n") return() } # fin si data2c <- as.data.frame(coordata) treeag <- agnes(data2c,diss=FALSE,metric="ward") hclusa <- as.hclust(treeag) nbcla <- nrow(data2c) pjs <- rep(1,2*nbcla-1) ajs <- rep(1,2*nbcla-1) bjs <- rep(1,2*nbcla-1) noms <- rep("",2*nbcla-1) noms[1:nbcla] <- row.names(data2c) nbagr <- nrow(hclusa$merge) pdvagr <- 1:nbagr for (idag in pdvagr) { jcla <- nbcla + idag aj <- hclusa$merge[idag,1] bj <- hclusa$merge[idag,2] if (aj<0) { aj <- - aj } else { aj <- aj + nbcla } if (bj<0) { bj <- - bj } else { bj <- bj + nbcla } ajs [jcla] <- aj bjs [jcla] <- bj pj <- pjs[aj] + pjs[bj] pjs[jcla] <- pj nomj <- paste(noms[aj],noms[bj]) noms[jcla] <- nomj } # fin pour cat("Description de la classification \n") cadreCah2co() cat("| J | I(J) | A(J) | B(J) | P(J) | DESCRIPTION DES CLASSES DE LA HIERARCHIE |\n") cadreCah2co() for (idag in pdvagr) { jcla <- 2*nbcla - idag cat("| ",sprintf("%4d",jcla)," | ",sprintf("%7.3f",hclusa$height[idag])," | ") cat(sprintf("%4d",ajs[jcla])," | ",sprintf("%4d",bjs[jcla])," | ",sprintf("%4d",pjs[jcla])," | ") if (idag==1) { cat("[...]") } else { cat(noms[jcla]) } # fin si cat("\n") } # fin pour cadreCah2co() if (graphique) { cat("voici le dendrogramme \n") #plclust(hclusa,hang=-1) phyhclusa <- as.phylo(hclusa) # as.phylo est dans le package ape # phyhclusa <- rotate(phyhclusa,Ntip(phyhclusa)+1) #plot.phylo(phyhclusa,direction="leftwards",...) plot.phylo(x=phyhclusa,direction="leftwards",tip.color=coulCAH,cex=vcex,adj=vadj) # retournement ? } # fin si return(hclusa) } # fin de fonction cah2co ################################################################# ################################################################# ## ## autres fonctions ## ################################################################# ################################################################# tmp <- function() { ################################################################# setwd("~/Tmp") } # fin de fonction tmp ################################################################# attends <- function(txt="") { ################################################################# # on pose une question et si la réponse n'est pas <Entrée>, on quitte le programme en cours if (txt!="") { cat(txt,"\n") } rep <- readline("ok ? ") if (!rep=="") { stop("Vous avez demandé d'arrêter ce programme.") } } # fin de fonction attends ################################################################# ouinon <- function() { ################################################################# return(c("oui","non")) } # fin de fonction ouinon ################################################################# nonoui <- function() { ################################################################# return(c("non","oui")) } # fin de fonction nonoui ################################################################# nomDeFichier <- function(nomav="") { ################################################################# # produit un nom de fichier valide nomap <- nomav nomap <- gsub("/","d",nomap) nomap <- gsub(" ","_",nomap) nomap <- gsub("\\+","p",nomap) return(nomap) } # fin de fonction nomDeFichier ################################################################# lesColonnes <- function(df,ordered=TRUE,envar=FALSE,print=TRUE,title="") { ################################################################# # lesColonnes(df) : les variables sont par ordre alphabétique # lesColonnes(df,ordered=FALSE) : les variables sont par numéro de colonne croissant # si envar=TRUE on renvoie la variable du tableau des colonnes # si print=TRUE on affiche nbc <- ncol(df) nbl <- nrow(df) if (print) { cat("Voici l'analyse des ",nbc,"colonnes (stat. pour ",nbl," lignes en tout)") if (title!="") { cat(" pour ",title) } # fin si cat("\n\n") } # fin si noms <- names(df) nbvs <- rep(NA,nbc) mins <- rep(NA,nbc) maxs <- rep(NA,nbc) dist <- rep(NA,nbc) miss <- rep(NA,nbc) miss <- rep(NA,nbc) typs <- rep("",nbc) ddc <- cbind((1:nbc),nbvs,mins,maxs,dist,miss,typs) row.names(ddc) <- noms colnames(ddc) <- c("Num","NbVal","Min","Max","Distinct","Manquantes","Type") pdc <- 1:nbc for (idc in pdc) { laCol <- df[,idc] laCol <- laCol[!is.na(laCol)] ddc[idc,2] <- length(laCol) if (length(laCol)==0) { ddc[idc,3] <- NA ddc[idc,4] <- NA } else { if (is.factor(laCol)) { lacoln <- as.numeric(laCol) ddc[idc,3] <- levels(laCol)[min(lacoln)] ddc[idc,4] <- levels(laCol)[max(lacoln)] } else { if (is.numeric(laCol)) { ddc[idc,3] <- sprintf("%0.3f",min(laCol)) ddc[idc,4] <- sprintf("%0.3f",max(laCol)) } else { ddc[idc,3] <- substr(min(laCol),1,10) ddc[idc,4] <- substr(max(laCol),1,10) } # fin si } # fin si } # fin si ddc[idc,5] <- length(unique(laCol)) ddc[idc,6] <- sum(is.na(df[,idc])) ddc[idc,7] <- paste(class(laCol),collapse=" ") } # fin pour idc if (ordered) { # tri par ordre alphabétique des noms de variables idx <- order(noms) ddc <- ddc[idx,] } # fin si if (print) { print.data.frame(as.data.frame(ddc),quote=FALSE,row.names=TRUE) cat("\n") } # fin si if (envar) { return(as.data.frame(ddc)) } else { return() } # fin de si } # fin de fonction lesColonnes ################################################################# somCols <- function(df) { ################################################################# nbc <- ncol(df) nbl <- nrow(df) cat("Voici les ",nbc,"colonnes et leur somme (stat. sur ",nbl," lignes en tout)\n\n") noms <- names(df) nbvs <- rep(NA,nbc) mins <- rep(NA,nbc) maxs <- rep(NA,nbc) soms <- rep(NA,nbc) ddc <- cbind((1:nbc),nbvs,mins,maxs,soms) row.names(ddc) <- noms colnames(ddc) <- c("Num","NbVal","Min","Max","Somme") pdc <- 1:nbc for (idc in pdc) { laCol <- as.numeric(df[,idc]) laCol <- laCol[!is.na(laCol)] ddc[idc,2] <- length(laCol) ddc[idc,3] <- min(laCol) ddc[idc,4] <- sum(laCol) } # fin pour print(ddc) } # fin de fonction somCols ################################################################# rownames <- function(nom) { ################################################################# # comme colnames return( row.names(nom) ) } # fin de fonction rownames ################################################################# lesVariables <- function(df,maxVar=0,lng=0) { ################################################################# library(gdata) # pour trim # on renvoie le nom des variables sous forme d'une seule chaine # de caractères ; si max est positif, on ne renvoie que les max # premiers noms et on rajoute "..." s'il y a plus de mx variables lesNoms <- names(df) if (lng>0) { fmtS <- paste("%-",lng,"s ",sep="") lesNoms <- sprintf(fmtS,lesNoms) } ; # fin si nomDesVariables <- paste(lesNoms,collapse=" ") if (maxVar>0) { minv <- min(ncol(df),maxVar) nomDesVariables <- paste(lesNoms[1:minv],collapse=" ") if (ncol(df)>maxVar) { nomDesVariables <- paste(trim(nomDesVariables),"... ",sep="") } ; # fin si } ; # fin si return(trim(nomDesVariables)) } # fin de fonction lesVariables ################################################################# gr <- function(fichier,largeur=1400,hauteur=1000) { ################################################################# #cat("png en ",largeur," x " ,hauteur,"\n") png(filename=fichier,width=largeur,height=hauteur) } # fin de fonction gr ################################################################# devoff <- function(fichier="") { ################################################################# dev.off() if (!fichier=="") { cat("\n -- OK pour fichier graphique",fichier,"\n") } } # fin de fonction devoff() ################################################################# finsink <- function(fichier="") { ################################################################# sink() if (!fichier=="") { cat("\n -- OK pour fichier texte",fichier,"\n") } } # fin de fonction finsink ################################################################# z <- function() { ################################################################# quit("no") } # fin de fonction z ################################################################# strlen <- function(string) { ################################################################# # renvoie le nombre de caractères comme en PHP return(nchar(string)) } # fin de fonction strlen ################################################################# lib <- function(pack) { ################################################################# # un alias pour un library() silencieux library(paste('"',pack,'"',collapse=""),warn.conflicts=FALSE) } # fin de fonction lib ################################################################# charToNum <- function(string) { ################################################################# # renvoie le code ascii des caractères # ce n'est pas un alias de charToRaw car on renvoie en décimal, pas en hexa return(strtoi(charToRaw(string),base=16)) } # fin de fonction charToNum ################################################################# asc <- function(string) { ################################################################# # renvoie le code ascii des caractères (un alias de charToNum) return(charToNum(string)) } # fin de fonction asc ################################################################# chr <- function(vector) { ################################################################# # renvoie les caractères correspond aux codes ascii (un alias de rawToChar) return(rawToChar(as.raw(vector))) } # fin de fonction chr ################################################################# dimdf <- function(df) { ################################################################# # renvoie nbLigxnbCol en format caractères (utile pour cats) return(paste(nrow(df),"x",ncol(df),sep="")) } # fin de fonction dimdf ################################################################# enColonnes <- function(vecteur,nbCol=4,largeur=7,nbDec=3) { ################################################################# cat("Affichage des",length(vecteur)," valeurs de \"V\" sur",nbCol, " colonnes, largeur=",largeur," avec",nbDec,"décimales\n") format <- paste(" %",largeur,".",nbDec,"f",sep="") v <- sprintf(format,vecteur) for (ide in seq(v)) { cat(v[ide]," ") if ((ide%%nbCol)==0) { cat("\n") } } # fin pour ide cat("\n") } # fin de fonction enColonnes ################################################################# bloc <- function(sd,deblig=5,debcol=NA,finlig=NA,fincol=NA,ret=FALSE) { ################################################################# if (missing(sd)) { cat("\n") cat("bloc : affiche un bloc [rectangulaire] de données\n\n") cat(" syntaxe : bloc(données,deblig,finlig,debcol,fincol)\n") cat(" exemple : bloc(matrice,deblig=3,finlig=8,debcol=6,fincol=10) affiches les lignes 3 à 8, colonnes 6 à 10\n") cat(" avec un seul paramètre n, affiches les lignes 1 à n, colonnes 1 à n") cat(" avec deux paramètres n et p, affiches les lignes 1 à n, colonnes 1 à p") } else { if (is.na(deblig)) { deblig <- 1 } if (is.na(finlig)) { finlig <- deblig ; deblig <- 1 } if (is.na(fincol)) { fincol <- debcol ; debcol <- 1 } if (is.na(fincol)) { fincol <- finlig } if (deblig>finlig) { tmp <- deblig deblig <- finlig finlig <- tmp } # fin si if (debcol>fincol) { tmp <- debcol debcol <- fincol fincol <- tmp } # fin si cat(" lignes ",deblig," à ",finlig," et colonnes ",debcol," à ",fincol," ; en tout : ",nrow(sd),"lignes et ",ncol(sd)," colonnes\n") if (deblig>nrow(sd)) { deblig <- nrow(sd) } if (finlig>nrow(sd)) { finlig <- nrow(sd) } if (debcol>ncol(sd)) { debcol <- ncol(sd) } if (fincol>ncol(sd)) { fincol <- ncol(sd) } if (ret) { return( sd[(deblig:finlig),(debcol:fincol)] ) } else { print(sd[(deblig:finlig),(debcol:fincol)]) } # finsi } # fin de si } # fin de fonction bloc ################################################################# extrait <- function(df,titre="",nblig=5,nbcol=5) { ################################################################# # le début et la fin des données nbl <- min(nrow(df),nblig) nbc <- min(ncol(df),nbcol) cats(paste("Extrait des données ",titre," (",dims(df),") sur ",nbl," lignes et ",nbc," colonnes",sep="")) print(head(df[,(1:nbc)],n=nbl)) cat("[...]\n") print(tail(df[,(1:nbc)],n=nbl)) } # fin de fonction extrait ################################################################# hhead <- function(df,c=10,n=6,nstart=1,cstart=1,ret=FALSE) { ################################################################# # un appel de bloc avec des valeurs par défaut et un ordre des paramètres usuels if (ret) { return( bloc(df,deblig=nstart,debcol=cstart,finlig=c,fincol=6) ) } else { bloc(df,deblig=nstart,debcol=cstart,finlig=c,fincol=6) } # finsi } # fin de fonction hhead ################################################################# bioc <- function() { ################################################################# source("http://bioconductor.org/biocLite.R") } # fin de fonction bioc ################################################################# parPrint <- function() { ################################################################# # mieux que : print( par() ) # sachant que ni sort( par() ) ni order( par() ) ne fonctionnent lesPg <- par() nomPg <- names(lesPg) idx <- order(nomPg) nbElt <- length(lesPg) matPg <- matrix(nrow=nbElt,ncol=3) colnames(matPg) <- c("Paramètre","Longueur","Valeur") for (idp in 1:nbElt) { jdp <- idx[idp] matPg[idp,1] <- nomPg[jdp] eltPg <- lesPg[[jdp]] lngElt <- length(eltPg) matPg[idp,2] <- lngElt if (lngElt==1) { if (is.na(eltPg)) { eltPg <- "<<NA>>" } # finsi if (is.null(eltPg)) { eltPg <- "<<nul>>" } # finsi if (eltPg=="") { eltPg <- "<<vide>>" } # finsi matPg[idp,3] <- eltPg } else { if (is.numeric(eltPg)) { eltPg <- round(eltPg,2) } # finsi strValeurPg <- ghtrim(paste(eltPg,collapse=" ")) matPg[idp,3] <- strValeurPg } # fin si } # fin pour idp print(matPg,quote=FALSE) } # fin de fonction parPrint ################################################################# optionsPrint <- function(triType=FALSE) { ################################################################# # mieux que options() # sachant que ni sort( options() ) ni order( options() ) ne fonctionnent lesOpt <- options() leso <- options() nomOpt <- names(lesOpt) typOpt <- lapply(X=lesOpt,FUN=typeof) if (triType) { idx <- order(unlist(unname(as.vector(typOpt))),nomOpt) } else { idx <- order(nomOpt) } # finsi nbElt <- length(lesOpt) matOpt <- matrix(nrow=nbElt,ncol=4) colnames(matOpt) <- c("Option","Type","Longueur","Valeur") for (idp in 1:nbElt) { jdp <- idx[idp] matOpt[idp,1] <- nomOpt[jdp] cat("idp",idp,"jdp",jdp,":",nomOpt[jdp],"\n") if (jdp==23) browser() eltOpt <- lesOpt[[jdp]] # cat("eltOpt",paste(eltOpt,collapse=" "),"\n") lngElt <- length(eltOpt) matOpt[idp,2] <- typeof(eltOpt) matOpt[idp,3] <- lngElt if (typeof(eltOpt)=="closure") { matOpt[idp,4] <- "<<function...>>" } else if (typeof(eltOpt)=="list") { matOpt[idp,4] <- paste(names(eltOpt),eltOpt,sep="=",collapse=" ") } else { if (lngElt==1) { if (is.na(eltOpt)) { eltOpt <- "<<NA>>" } # finsi if (is.null(eltOpt)) { eltOpt <- "<<nul>>" } # finsi if (eltOpt=="") { eltOpt <- "<<vide>>" } # finsi matOpt[idp,4] <- eltOpt } else { if (is.numeric(eltOpt)) { eltOpt <- round(eltOpt,2) } # finsi strValeurPg <- ghtrim(paste(eltOpt,collapse=" ")) matOpt[idp,4] <- strValeurPg } # fin si } # fin si } # fin pour idp print(matOpt,quote=FALSE) } # fin de fonction optionsPrint ################################################################# copies <- function(string,nrep=0) { ################################################################# # renvoie n copies de la chaine string res <- "" if (nrep>0) { for (idc in (1:nrep)) { res <- paste(res,string,sep="") } } return(res) } # fin de fonction copies ################################################################# versiongh <- function() { ################################################################# cat(" statgh.r : ",version_gH," pour ",R.Version()$version.string,"\n") } # fin de fonction versiongh ################################################################# sinksource <- function(fName,encoding="latin1",split=TRUE,...) { ################################################################# # # fait un sink puis un source et ferme le sink # exemple : sinksource("test") ==> exécute test.r, affiche à l'écran et produit test.sor # ==> du coup, cela s'affiche a l'écran et c'est aussi stocké dans # un fichier de meme nom que le programme. baseName <- fName lng <- nchar(fName) if (substr(fName,lng-1,lng)==".r") { baseName <- substr(fName,1,lng-2) } # fin si fs <- paste(baseName,".sor",sep="") fp <- paste(baseName,".r",sep="") unlink(fs) sink(fs,split=split) source(fp,encoding=encoding,print.eval=TRUE,...) sink() cat("\n\n vous pouvez utiliser ",fs,"\n") } # fin de fonction sinksource ################################################################# src <- function(fn) { ################################################################# source(fn,encoding="latin1",print.eval=TRUE) } # fin de fonction src ################################################################# run <- function(fn,...) { ################################################################# duree(source(fn,encoding="latin1",...)) } # fin de fonction run ################################################################# sorsrc <- function(fn) { ################################################################# sinksource(fn,encoding="latin1") } # fin de fonction sorsrc ################################################################# sinksrc <- function(fn,...) { ################################################################# sinksource(fn,encoding="latin1",...) } # fin de fonction sinksrc ################################################################# htmlsrc <- function(fn,...) { ################################################################# # éxécute un fichier de commande et recopie ce qu'on voit dans une page Web # puis affiche cette page ; ne fonctionne pas bien sur toutes les machines Windows... library(R2HTML) HTMLStart(filename="dynamic",echo=TRUE) #source(fn,encoding="latin1",echo=TRUE) cats("debut") ; cat("milieu") ; cats("fin") ; webadr <- HTMLStop() browseURL(url=webadr,browser="firefox") } # fin de fonction htmlsrc ################################################################# debutHtml <- function() { ################################################################# library(R2HTML) HTMLStart(filename="dynamic",echo=TRUE) } # fin de fonction debutHtml ################################################################# finHtml <- function() { ################################################################# webadr <- HTMLStop() browseURL(url=webadr,browser="firefox") } # fin de fonction finHtml ################################################################# ddata <- function(package="datasets") { ################################################################# # affiche les tailles des données disponibles via data() cats(paste("Jeux de données du package",package)) dfd <- data(package=package) # print(length(dfd)) renvoie 4 ndd <- dfd$results[,"Item"] if (length(ndd)==0) { cat("\n aucun jeu de données vu dans ce package.\n\n") } else { # préparation de la matrice des résultats mres <- matrix(nrow=length(ndd),ncol=6) mres <- data.frame(mres) colnames(mres) <- c("name","class","length","nrow","ncol","name2") row.names(mres) <- paste("data_",sprintf("%03d",1:nrow(mres)),sep="") nd <- 0 for (idd in ndd) { nd <- nd + 1 jdd <- strsplit(x=idd,split=" ")[[1]][1] # le premier mot kdd <- strsplit(x=idd,split=" ")[[1]][2] # le deuxieme mot avec des parenthes eventuelles kdd <- gsub("[()]","",kdd) if (is.na(kdd)) { phr <- paste(" data(",jdd,",package='",package,"')",sep="") } else { phr <- paste(" data(",kdd,",package='",package,"')",sep="") } # finsi eval(parse(text=phr)) ddd <- get(jdd) mres[nd,2] <- paste(class(ddd),collapse=" ") if (!is.null(length(ddd))) { mres[nd,3] <- length(ddd) if (length(class(ddd))==1) { if (class(ddd)=="matrix") { mres[nd,3] <- NA } if (class(ddd)=="data.frame") { mres[nd,3] <- NA } } # finsi } # finsi if (!is.null(nrow(ddd))) { mres[nd,4] <- nrow(ddd) } # finsi if (!is.null(ncol(ddd))) { mres[nd,5] <- ncol(ddd) } # finsi mres[nd,6] <- kdd mres[nd,1] <- jdd } # fin pour # on trie par nom de jeu de données idx <- order(toupper(row.names(mres))) mres <- mres[idx,] mres[is.na(mres)] <- "" # on reformate les chaines a gauche lm1 <- max(nchar(mres[,1])) mres[,1] <- substr(paste(mres[,1],copies("_",lm1)),1,lm1) lm2 <- max(nchar(mres[,2])) mres[,2] <- substr(paste(mres[,2],copies("_",lm2)),1,lm2) lm6 <- max(nchar(mres[,6])) mres[,6] <- substr(paste(mres[,6],copies("_",lm6)),1,lm6) #print(mres,right=FALSE) print(mres) } # fin si } # fin de fonction ddata ################################################################# lls <- function(package="base") { ################################################################# # affiche les tailles des objets disponibles via ls() cats(paste("Objets du package",package)) # il faut d'abord charger le package phr <- paste('ldp <- library("',package,'")',sep="") eval(parse(text=phr)) # si on ne trouve pas le nom du package dans ldp # c'est qu'on n'a pas pas réussi à le charger if (!package %in% ldp) { cat("Package ",package," non chargé.\n") return(invisible(NULL)) } # fin si phr <- paste('oip <- ls("package:',package,'")',sep="") eval(parse(text=phr)) cat(" il y a ",length(oip)," objets dans ce package\n\n") ## oip <- c(head(oip),tail(oip)) # préparation de la matrice des résultats mres <- matrix(nrow=length(oip),ncol=3) mres <- data.frame(mres) colnames(mres) <- c("name","functionClass","other") row.names(mres) <- paste("obj_",sprintf("%03d",1:nrow(mres)),sep="") nd <- 0 for (idd in oip) { nd <- nd + 1 mres[nd,1] <- idd jdd <- get(idd) clj <- class(jdd) if (length(clj)==1) { if (class(jdd) %in% c("function","standardGeneric")) { mres[nd,2] <- clj } else { mres[nd,3] <- clj } # fin si } else { mres[nd,3] <- paste(clj,collapse=" & ") } # fin si #mres[nd,3] <- args(jdd) } # fin pour mres[is.na(mres)] <- "" print(mres,right=FALSE) } # fin de fonction lls ################################################################# reformate <- function(col) { # ################################################################# lm <- max(nchar(col)) return( substr(paste(col,copies("_",lm)),1,lm) ) } # fin de fonction reformate ################################################################# pwd <- function() { # comme sous Unix ################################################################# getwd() } # fin de fonction pwd ################################################################# cb <- function(x,...) { # un alias de cbind, util pour cb(names(df)) ################################################################# return(cbind(x)) } # fin de fonction cb ################################################################# cd <- function(chemin="") { # comme sous Windows ################################################################# if (chemin=="") { getwd() } else { setwd(chemin) } ; # fin si } # fin de fonction pwd ################################################################# go <- function(cd) { # changer rapidement de répertoire ################################################################# if (missing(cd)) { cat("syntaxe : go(raccourci) \n") return(invisible(0)) } # fin si fabr <- "~/Bin/gilhp.cds" if (!file.exists(fabr)) { cat(" fichier ",fabr,"non vu \n") } # fin si ftxt <- readLines(fabr,n=-1) for (lig in ftxt) { tdc <- unlist(strsplit(lig,"\\s+",perl=TRUE)) #print(tdc) if (tdc[1]==cd) { leCd <- tdc[2] } } # fin pour setwd(leCd) cat(" cd = ",getwd(),"\n") } # fin de fonction pwd ################################################################# catn <- function() { ################################################################# cat("\n") } # fin de fonction catn ################################################################# cats <- function(chen="",soulign="=") { # sert à souligner ################################################################# cat("\n") cat(chen,"\n") cat(copies(soulign,strlen(chen)),"\n") cat("\n") } # fin de fonction cats ################################################################# catss <- function(chen="",soulign="=") { # sert à encadrer ################################################################# cat("\n") cat("+",copies(soulign,strlen(chen)),"+\n") cat("+",copies(" ",strlen(chen)),"+\n") cat("+",chen,"+\n") cat("+",copies(" ",strlen(chen)),"+\n") cat("+",copies(soulign,strlen(chen)),"+\n") cat("\n") } # fin de fonction catss ################################################################# hprint <- function(x) { ################################################################# # visualisation dans Firefox de l'objet (on utilise hwriter) library(hwriter) tmpdir <- tempdir() filename <- file.path(tmpdir, "hprint_gh.html") pageGh <- openPage(filename, link.css = "hwriter.css") row.names(x) <- 1:nrow(x) hwrite(x,pageGh) closePage(pageGh) try(browseURL(paste("file://", filename, sep = ""))) } # fin de fonction hprint ################################################################# noask <- function() { ################################################################# # évite d'avoir Tapez <Entrée> pour voir le graphique suivant # et d'appuyer sur entrée. par(ask=FALSE) } # fin de fonction noask ################################################################# showColors <- function(col=colors()[1:100], nrow=10, ncol=ceiling(length(col) / nrow), txt.col="black") { ################################################################# par(ask=FALSE) stopifnot(nrow >= 1, ncol >= 1) if(length(col) > nrow*ncol) warning("some colors will not be shown") require(grid) grid.newpage() gl <- grid.layout(nrow, ncol) pushViewport(viewport(layout=gl)) ic <- 1 for(i in 1:nrow) { for(j in 1:ncol) { pushViewport(viewport(layout.pos.row=i, layout.pos.col=j)) grid.rect(gp= gpar(fill=col[ic])) grid.text(col[ic], gp=gpar(col=txt.col)) upViewport() ic <- ic+1 } } upViewport() invisible(gl) print(cbind(col)) } # fin de fonction showColors ################################################################# couleursNmds <- function() { ################################################################# couleurs <- c("firebrick3", "dodgerblue3", "chartreuse4","darkorchid", "gray45", "orange4", "yellow3") couleurs <- c(couleurs,"cyan","coral","chartreuse","darkblue","darkolivegreen1","darkgreen","darkorange1") couleurs <- c(couleurs,"indianred1","bisque2") return(couleurs) } # fin de fonction couleursNmds ################################################################# duree <- function(...) { # exemple de fonction duree ################################################################# # on utilise le package lubridate car plus agréable que Sys.time() library(lubridate) tempsDeb <- now() eval.parent(...) tempsFin <- now() cat("\n\n -- fin de script \n") cat("durée entre = ",format(tempsDeb,"%c")," et ",format(tempsFin,"%c")," = ",tempsFin-tempsDeb,"\n") return(tempsFin-tempsDeb) } # fin de fonction duree ################################################################################### exprimeDuree <- function(timeDeb,timeFin) { ################################################################################### # timeDeb et timeFin sont en principe générés par now() du package lubridate if (timeDeb>timeFin) { timeTmp <- timeDeb timeDeb <- timeFin timeFin <- timeTmp } # fin si dur <- timeFin-timeDeb #print(dur) dur <- unclass( dur ) #print(dur) #cat(" v1 ",dur,"\n") durh <- 0 durm <- 0 durs <- 0 if (attributes(dur)=="hours") { durh <- dur } # finsi if (attributes(dur)=="mins") { durm <- dur } # finsi if (attributes(dur)=="secs") { durs <- dur } # finsi #cat(" v2 ",durh," h ",durm," min ",durs,"s.\n") rdurh <- trunc(durh) if (durh>rdurh) { durm <- durm + 60*(durh-rdurh) durh <- rdurh } # fin si rdurm <- trunc(durm) if (durm>rdurm) { durs <- durs + 60*(durm-rdurm) durm <- rdurm } # fin si durs <- round( durs ) if (durh>0) { cat(" ",durh," h ") } if (durm>0) { cat(" ",durm," min") } cat(" ",durs,"s.\n") } # fin de fonction exprimeDuree ################################################################# regh <- function() { ################################################################# fn <- "statgh.r" if (file.exists(fn)) { source(fn,encoding="latin1") # return(".") return(invisible(NULL)) } ; # finsi fn <- "~/Bin/statgh.r" if (file.exists(fn)) { source(fn,encoding="latin1") return("~/Bin") } ; # finsi fn <- "~/public_html/statgh.r" if (file.exists(fn)) { source(fn,encoding="latin1") return("~/Bin") } ; # finsi fn <- "X:/Bin/statgh.r" if (file.exists(fn)) { source(fn,encoding="latin1") return("X:/") } ; # finsi fn <- "K:/Stat_ad/statgh.r" if (file.exists(fn)) { source(fn,encoding="latin1") return("K:/Stat_ad") } ; # finsi return(invisible(NULL)) } # fin de fonction regh .regh <- regh ################################################################# redata <- function() { ################################################################# source("datagh.r",encoding="latin1") } # fin de fonction redata ################################################################# aide <- function() { ################################################################# cat("\n\n (gH) version ",version_gH,"\n\n") cat("fonctions d'aides : lit() fqt() fql() ic() fapprox() chi2() fcomp() datagh() \n") ; cat("taper aide() pour revoir cette liste\n\n") return(invisible(NULL)) } ; # fin de fonction aide ################################################################# installe <- function(packages="") { ################################################################# install.packages(pkgs=packages,dependencies=TRUE) } ; # fin de fonction installe ################################################################# ruler <- function(n=100) { ################################################################# # affiche une réglette pour voir la largeur d'affichage for (ic in 1:n) { if ((ic%%10)==0) { cat( sprintf("%10s",ic) ) } # fin si } # fin pour cat("\n") ic = 2 ; lc = "|" ; while (ic<=n) { if ((ic%%10)==0) { lc <- paste(lc,"|",sep="") } else { if ((ic%%5)==0) { lc <- paste(lc,"+",sep="") } else { lc <- paste(lc,".",sep="") } # fin si } # fin si ic <- ic + 1 } # fin tant que cat(lc,"\n") } ; # fin de fonction ruler ################################################################# ################################################################# aide() ## fin de statgh.r Cliquer ici pour revenir à la page de départ   Code-source de la page    explications    archive zip du code de statgh.r

 

 

   Retour à la page principale de   (gH)