1 #datadm<-read.table('/home/pierre/.hippasos/corpus_agir_CHDS_16/fileACTtemp.csv', header=TRUE,sep=';', quote='\"',row.names = 1, na.strings = 'NA')
3 #dissmat<-daisy(dataact, metric = 'gower', stand = FALSE)
4 #chd<-diana(dissmat,diss=TRUE,)
6 #sortheight<-sort(height,decreasing=TRUE)
7 FindBestCluster<-function (x,Max=15) {
23 ListClasseOk[[j]]<-i+1
30 #BestCLusterNb<-FindBestCluster(sortheight)
31 #classes<-as.data.frame(cutree(as.hclust(chd), k=6))[,1]
32 #datadm<-cbind(datadm,classes)
33 #clusplot(datadm,classes,shade=TRUE,color=TRUE,labels=4)
35 BuildContTable<- function (x) {
37 for (i in 1:(ncol(x)-1)) {
38 coltable<-table(x[,i],x$classes)
39 afctable<-rbind(afctable,coltable)
44 PrintProfile<- function(dataclasse,profileactlist,profileetlist,antiproact,antiproet,clusternb,profileout,antiproout,profilesuplist=NULL,antiprosup=NULL) {
48 cltot<-as.data.frame(dataclasse[dataclasse[,ncol(dataclasse)]!=0,])
49 cltot<-as.data.frame(as.character(cltot[,ncol(cltot)]))
51 classes<-as.data.frame(as.character(dataclasse[,ncol(dataclasse)]))
52 classes.s<-as.data.frame(summary(cltot[,1],maxsum=500))
53 profile<-rbind(profile,c('***','nb classes',clusternb,'***','',''))
54 antipro<-rbind(antipro,c('***','nb classes',clusternb,'***','',''))
55 for(i in 1:clusternb) {
56 profile<-rbind(profile,c('**','classe',i,'**','',''))
57 nbind<-classes.s[which(rownames(classes.s)==i),1]
58 pr<-round((nbind/tot)*100,digits=2)
59 profile<-rbind(profile,c('****',nbind,tot,pr,'****',''))
60 if (length(profileactlist[[1]][[i]])!=0){
61 profile<-rbind(profile,as.matrix(profileactlist[[1]][[i]]))
63 if (!is.null(profilesuplist)) {
64 profile<-rbind(profile,c('*****','*','*','*','*','*'))
65 if (length(profilesuplist[[1]][[i]])!=0) {
66 profile<-rbind(profile,as.matrix(profilesuplist[[1]][[i]]))
69 if (!is.null(profileetlist)) {
70 profile<-rbind(profile,c('*','*','*','*','*','*'))
71 if (length(profileetlist[[1]][[i]])!=0) {
72 profile<-rbind(profile,as.matrix(profileetlist[[1]][[i]]))
75 antipro<-rbind(antipro,c('**','classe',i,'**','',''))
76 antipro<-rbind(antipro,c('****',nbind,tot,pr,'****',''))
77 if (length(antiproact[[1]][[i]])!=0) {
78 antipro<-rbind(antipro,as.matrix(antiproact[[1]][[i]]))
80 if (!is.null(profilesuplist)) {
81 antipro<-rbind(antipro,c('*****','*','*','*','*','*'))
82 if (length(antiprosup[[1]][[i]])!=0) {
83 antipro<-rbind(antipro,as.matrix(antiprosup[[1]][[i]]))
86 if (!is.null(profileetlist)) {
87 antipro<-rbind(antipro,c('*','*','*','*','*','*'))
88 if (length(antiproet[[1]][[i]])!=0) {
89 antipro<-rbind(antipro,as.matrix(antiproet[[1]][[i]]))
93 write.csv2(profile,file=profileout,row.names=FALSE)
94 write.csv2(antipro,file=antiproout,row.names=FALSE)
97 AddCorrelationOk<-function(afc) {
98 rowcoord<-afc$rowcoord
99 colcoord<-afc$colcoord
100 factor <- ncol(rowcoord)
101 hypo<-function(rowcoord,ligne) {
103 for (i in 1:factor) {
104 somme<-somme+(rowcoord[ligne,i])^2
108 cor<-function(d,hypo) {
111 CompCrl<-function(rowcol) {
113 for (i in 1:factor) {
114 for(ligne in 1:nrow(rowcol)) {
115 out[ligne,i]<-cor(rowcol[ligne,i],hypo(rowcol,ligne))
120 afc$rowcrl<-CompCrl(rowcoord)
121 afc$colcrl<-CompCrl(colcoord)
125 AsLexico<- function(x) {
132 mod.names<-rownames(x)
133 #problem exemple aurelia
134 for (classe in 1:ncol(x)) {
136 for (ligne in 1:nrow(x)) {
137 conttable<-matrix(0,2,2)
138 conttable[1,1]<-as.numeric(x[ligne,classe])
139 conttable[1,2]<-sumrow[ligne]-conttable[1,1]
140 conttable[2,1]<-sumcol[classe]-conttable[1,1]
141 conttable[2,2]<-tot-sumrow[ligne]-conttable[2,1]
142 chiresult<-chisq.test(conttable,correct=TRUE)
143 if (is.na(chiresult$p.value)) {
145 chiresult$statistic<-0
147 obsv<-chiresult$expected
148 pval<-as.character(format(chiresult$p.value,scientific=TRUE))
149 spval<-strsplit(pval,'e')
153 if (conttable[1,1]>obsv[1,1]) {
154 tablep[ligne,classe]<-as.numeric(spval[[1]][2])*(-1)
155 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
157 else if (conttable[1,1]<obsv[1,1]){
158 tablep[ligne,classe]<-as.numeric(spval[[1]][2])
159 tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
164 eff_relatif<-(x/sumcol)*1000
166 output[[2]]<-tablesqr
167 output[[3]]<-eff_relatif
171 MyChiSq<-function(x){
175 E <- outer(sr, sc, "*")/n
176 STAT<-sum((abs(x - E))^2/E)
177 PVAL <- pchisq(STAT, 1, lower.tail = FALSE)
178 chi<-list(statistic = STAT, expected = E, p.value = PVAL)
182 AsLexico2<- function(mat, chip = FALSE) {
190 for (i in 1:nrow(contcs)) {
194 contrs[,1:ncol(contrs)] <- sumrow
195 conttot <- matrix(tot, nrow = nrow(mat), ncol = ncol(mat))
196 cont12 <- contrs - mat
197 cont21 <- contcs - mat
198 cont22 <- conttot - contrs - cont21
199 mod.names<-rownames(mat)
200 make_chi_lex <- function(x) {
206 chiresult<-MyChiSq(tb)
208 if (is.na(chiresult$p.value)) {
210 chiresult$statistic<-0
212 obsv<-chiresult$expected
213 pval<-as.character(format(chiresult$p.value,scientific=TRUE))
214 spval<-strsplit(pval,'e')
218 if (tb[1,1]>obsv[1,1]) {
219 as.numeric(spval[[1]][2])*(-1)
221 else if (tb[1,1]<obsv[1,1]){
222 as.numeric(spval[[1]][2])
227 make_chi_p <- function(x) {
233 chiresult<-MyChiSq(tb)
235 if (is.na(chiresult$p.value)) {
237 chiresult$statistic<-0
239 obsv<-chiresult$expected
240 if (tb[1,1]>obsv[1,1]) {
243 else if (tb[1,1]<obsv[1,1]){
249 make_chi <- function(x) {
255 chiresult<-MyChiSq(tb)
257 if (is.na(chiresult$p.value)) {
259 chiresult$statistic<-0
261 obsv<-chiresult$expected
262 if (tb[1,1]>obsv[1,1]) {
265 else if (tb[1,1]<obsv[1,1]){
272 res <- matrix(sapply(1:length(mat), make_chi_lex), ncol = ncol(mat))
273 rownames(res)<-mod.names
274 colnames(res) <- colnames(mat)
275 eff_relatif<-round(t(apply(mat,1,function(x) {(x/t(as.matrix(sumcol))*1000)})),2)
276 rownames(eff_relatif)<-mod.names
277 colnames(eff_relatif) <- colnames(mat)
279 reschip <- matrix(sapply(1:length(mat), make_chi_p), ncol = ncol(mat))
280 rownames(reschip)<- mod.names
281 colnames(reschip) <- colnames(mat)
282 reschi <- matrix(sapply(1:length(mat), make_chi), ncol = ncol(mat))
283 rownames(reschip)<- mod.names
284 colnames(reschip) <- colnames(mat)
288 out[[3]]<-eff_relatif
296 make.spec.hypergeo <- function(mat) {
298 spec <- specificities(mat)
300 eff_relatif<-round(t(apply(mat,1,function(x) {(x/t(as.matrix(sumcol))*1000)})),2)
301 colnames(eff_relatif) <- colnames(mat)
304 out[[3]]<-eff_relatif
308 BuildProf01<-function(x,classes) {
310 #classes : classes de chaque lignes de x
311 dm<-cbind(x,cl=classes)
312 clnb=length(summary(as.data.frame(as.character(classes)),max=100))
313 mat<-matrix(0,ncol(x),clnb)
314 rownames(mat)<-colnames(x)
316 dtmp<-dm[which(dm$cl==i),]
317 for (j in 1:(ncol(dtmp)-1)) {
318 mat[j,i]<-sum(dtmp[,j])
324 build.prof.tgen <- function(x) {
325 nbst <- sum(x[nrow(x),])
327 tottgen <- rowSums(x)
328 nbtgen <- nrow(x) - 1
329 chi2 <- x[1:(nrow(x)-1),]
331 for (classe in 1:ncol(x)) {
332 for (tg in 1:nbtgen) {
333 cont <- c(x[tg, classe], tottgen[tg] - x[tg, classe], totcl[classe] - x[tg, classe], (nbst - totcl[classe]) - (tottgen[tg] - x[tg, classe]))
334 cont <- matrix(unlist(cont), nrow=2)
335 chiresult<-chisq.test(cont,correct=FALSE)
336 if (is.na(chiresult$p.value)) {
338 chiresult$statistic<-0
340 if (chiresult$expected[1,1] > cont[1,1]) {
341 chiresult$statistic <- chiresult$statistic * -1
343 chi2[tg,classe] <- chiresult$statistic
344 pchi2[tg,classe] <- chiresult$p.value
347 res <- list(chi2 = chi2, pchi2 = pchi2)
350 BuildProf<- function(x,dataclasse,clusternb,lim=2) {
352 #r.names<-rownames(x)
354 #rownames(x)<-r.names
356 #nuce<-nrow(dataclasse)
357 sumcol<-paste(NULL,1:nrow(x))
358 colclasse<-dataclasse[,ncol(dataclasse)]
359 nuce <- length(which(colclasse != 0))
360 # for (i in 1:nrow(x)) {
361 # sumcol[i]<-sum(x[i,])
363 # afctablesum<-cbind(x,sumcol)
364 afctablesum <- cbind(x, rowSums(x))
365 #dataclasse<-as.data.frame(dataclasse[dataclasse[,ncol(dataclasse)]!=0,])
366 dataclasse<-as.matrix(dataclasse[dataclasse[,ncol(dataclasse)]!=0,])
372 mod.names<-rownames(x)
376 for (classe in 1:clusternb) {
377 lnbligne[classe]<-length(colclasse[colclasse==classe])
378 prof[[classe]]<-data.frame()
379 aprof[[classe]]<-data.frame()
382 for (ligne in 1:nrow(x)) {
383 for (classe in 1:clusternb) {
384 nbligneclasse<-lnbligne[classe]
385 conttable<-data.frame()
386 conttable[1,1]<-as.numeric(x[ligne,classe])
387 conttable[1,2]<-as.numeric(as.vector(x[ligne,ncol(x)]))-as.numeric(x[ligne,classe])
388 conttable[2,1]<-nbligneclasse-as.numeric(x[ligne,classe])
389 conttable[2,2]<-nrow(dataclasse)-as.numeric(as.vector(x[ligne,ncol(x)]))-conttable[2,1]
390 chiresult<-chisq.test(conttable,correct=FALSE)
391 if (is.na(chiresult$p.value)) {
393 chiresult$statistic<-0
396 obsv<-chiresult$expected
397 tablep[ligne,classe]<-round(chiresult$p.value,digits=3)
398 #tablep[ligne,classe]<-format(chiresult$p.value, scientific=TRUE)
399 if (chiresult$statistic>=lim) {
400 if (conttable[1,1]>obsv[1,1]) {
401 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
402 prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
403 prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
404 prof[[classe]][nrow(prof[[classe]]),3]<-round((as.numeric(as.vector(x[ligne,classe]))/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
405 prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
406 prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
407 prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
409 else if (conttable[1,1]<obsv[1,1]){
410 tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
411 aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
412 aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
413 aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
414 aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
415 aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
416 aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
418 #pour gerer le cas avec une seule v et par exemple
419 else if (conttable[1,1]==obsv[1,1]) {
420 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
421 prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
422 prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
423 prof[[classe]][nrow(prof[[classe]]),3]<-round((as.numeric(as.vector(x[ligne,classe]))/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
424 prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
425 prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
426 prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
427 aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
428 aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
429 aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
430 aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
431 aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
432 aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
435 if (conttable[1,1]>obsv[1,1]) {
436 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
437 } else if (conttable[1,1]<obsv[1,1]){
438 tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
440 #pour gerer le cas avec une seule v et par exemple
441 else if (conttable[1,1]==obsv[1,1]) {
442 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
448 for (classe in 1:clusternb) {
449 if (length(prof[[classe]])!=0) {
450 prof[[classe]]<-prof[[classe]][order(prof[[classe]][,4],decreasing=TRUE),]
452 if (length(aprof[[classe]])!=0) {
453 aprof[[classe]]<-aprof[[classe]][order(aprof[[classe]][,4]),]
458 output[[2]]<-tablesqr
459 output[[3]]<-afctablesum
466 build.pond.prof <- function(mat, lim = 2) {
468 mod.names<-rownames(mat)
476 clusternb <- ncol(mat)
477 x <- cbind(mat, rowSums(mat))
478 for (classe in 1:clusternb) {
479 prof[[classe]]<-data.frame()
480 aprof[[classe]]<-data.frame()
483 for (ligne in 1:nrow(mat)) {
484 for(classe in 1:ncol(mat)) {
486 tb[1,1] <- mat[ligne,classe]
487 tb[1,2] <- srow[ligne] - tb[1,1]
488 tb[2,1] <- scol[classe] - tb[1,1]
489 tb[2,2] <- tot - srow[ligne] - tb[2,1]
490 chiresult <- MyChiSq(tb)
491 if (is.na(chiresult$p.value)) {
493 chiresult$statistic<-0
495 tablep[ligne,classe]<-round(chiresult$p.value,digits=3)
497 obsv <- chiresult$expected
498 if (chiresult$statistic>=lim) {
499 if (conttable[1,1]>obsv[1,1]) {
500 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
501 prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
502 prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
503 prof[[classe]][nrow(prof[[classe]]),3]<-round((as.numeric(as.vector(x[ligne,classe]))/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
504 prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
505 prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
506 prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
508 else if (conttable[1,1]<obsv[1,1]){
509 tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
510 aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
511 aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
512 aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
513 aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
514 aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
515 aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
517 #pour gerer le cas avec une seule v et par exemple
518 else if (conttable[1,1]==obsv[1,1]) {
519 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
520 prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
521 prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
522 prof[[classe]][nrow(prof[[classe]]),3]<-round((as.numeric(as.vector(x[ligne,classe]))/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
523 prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
524 prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
525 prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
526 aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
527 aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
528 aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
529 aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
530 aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
531 aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
534 if (conttable[1,1]>obsv[1,1]) {
535 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
536 } else if (conttable[1,1]<obsv[1,1]){
537 tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
539 #pour gerer le cas avec une seule v et par exemple
540 else if (conttable[1,1]==obsv[1,1]) {
541 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
547 for (classe in 1:clusternb) {
548 if (length(prof[[classe]])!=0) {
549 prof[[classe]]<-prof[[classe]][order(prof[[classe]][,4],decreasing=TRUE),]
551 if (length(aprof[[classe]])!=0) {
552 aprof[[classe]]<-aprof[[classe]][order(aprof[[classe]][,4]),]
557 output[[2]]<-tablesqr