Les 267 fonctions de statgh.r

Les 267 fonctions de statgh.r (version 6.49)

Chargement des fonctions :

          source("http://forge.info.univ-angers.fr/~gh/wstat/statgh.r",encoding="latin1")

Choisissez la fonction :

## (gH) -_- statgh.r ; TimeStamp (unix) : 22 Juillet 2020 vers 13:29 # version_gH <- 6.49 ################################################################# # # +----------------------------------------------- (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("duree 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)