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 BuildProf<- function(x,dataclasse,clusternb,lim=2) {
326 #r.names<-rownames(x)
328 #rownames(x)<-r.names
330 #nuce<-nrow(dataclasse)
331 sumcol<-paste(NULL,1:nrow(x))
332 colclasse<-dataclasse[,ncol(dataclasse)]
333 nuce <- length(which(colclasse != 0))
334 # for (i in 1:nrow(x)) {
335 # sumcol[i]<-sum(x[i,])
337 # afctablesum<-cbind(x,sumcol)
338 afctablesum <- cbind(x, rowSums(x))
339 #dataclasse<-as.data.frame(dataclasse[dataclasse[,ncol(dataclasse)]!=0,])
340 dataclasse<-as.matrix(dataclasse[dataclasse[,ncol(dataclasse)]!=0,])
346 mod.names<-rownames(x)
350 for (classe in 1:clusternb) {
351 lnbligne[classe]<-length(colclasse[colclasse==classe])
352 prof[[classe]]<-data.frame()
353 aprof[[classe]]<-data.frame()
356 for (ligne in 1:nrow(x)) {
357 for (classe in 1:clusternb) {
358 nbligneclasse<-lnbligne[classe]
359 conttable<-data.frame()
360 conttable[1,1]<-as.numeric(x[ligne,classe])
361 conttable[1,2]<-as.numeric(as.vector(x[ligne,ncol(x)]))-as.numeric(x[ligne,classe])
362 conttable[2,1]<-nbligneclasse-as.numeric(x[ligne,classe])
363 conttable[2,2]<-nrow(dataclasse)-as.numeric(as.vector(x[ligne,ncol(x)]))-conttable[2,1]
364 chiresult<-chisq.test(conttable,correct=FALSE)
365 if (is.na(chiresult$p.value)) {
367 chiresult$statistic<-0
370 obsv<-chiresult$expected
371 tablep[ligne,classe]<-round(chiresult$p.value,digits=3)
372 #tablep[ligne,classe]<-format(chiresult$p.value, scientific=TRUE)
373 if (chiresult$statistic>=lim) {
374 if (conttable[1,1]>obsv[1,1]) {
375 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
376 prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
377 prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
378 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)
379 prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
380 prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
381 prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
383 else if (conttable[1,1]<obsv[1,1]){
384 tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
385 aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
386 aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
387 aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
388 aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
389 aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
390 aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
392 #pour gerer le cas avec une seule v et par exemple
393 else if (conttable[1,1]==obsv[1,1]) {
394 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
395 prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
396 prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
397 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)
398 prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
399 prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
400 prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
401 aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
402 aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
403 aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
404 aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
405 aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
406 aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
409 if (conttable[1,1]>obsv[1,1]) {
410 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
411 } else if (conttable[1,1]<obsv[1,1]){
412 tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
414 #pour gerer le cas avec une seule v et par exemple
415 else if (conttable[1,1]==obsv[1,1]) {
416 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
422 for (classe in 1:clusternb) {
423 if (length(prof[[classe]])!=0) {
424 prof[[classe]]<-prof[[classe]][order(prof[[classe]][,4],decreasing=TRUE),]
426 if (length(aprof[[classe]])!=0) {
427 aprof[[classe]]<-aprof[[classe]][order(aprof[[classe]][,4]),]
432 output[[2]]<-tablesqr
433 output[[3]]<-afctablesum
440 build.pond.prof <- function(mat, lim = 2) {
442 mod.names<-rownames(mat)
450 clusternb <- ncol(mat)
451 x <- cbind(mat, rowSums(mat))
452 for (classe in 1:clusternb) {
453 prof[[classe]]<-data.frame()
454 aprof[[classe]]<-data.frame()
457 for (ligne in 1:nrow(mat)) {
458 for(classe in 1:ncol(mat)) {
460 tb[1,1] <- mat[ligne,classe]
461 tb[1,2] <- srow[ligne] - tb[1,1]
462 tb[2,1] <- scol[classe] - tb[1,1]
463 tb[2,2] <- tot - srow[ligne] - tb[2,1]
464 chiresult <- MyChiSq(tb)
465 if (is.na(chiresult$p.value)) {
467 chiresult$statistic<-0
469 tablep[ligne,classe]<-round(chiresult$p.value,digits=3)
471 obsv <- chiresult$expected
472 if (chiresult$statistic>=lim) {
473 if (conttable[1,1]>obsv[1,1]) {
474 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
475 prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
476 prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
477 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)
478 prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
479 prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
480 prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
482 else if (conttable[1,1]<obsv[1,1]){
483 tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
484 aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
485 aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
486 aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
487 aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
488 aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
489 aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
491 #pour gerer le cas avec une seule v et par exemple
492 else if (conttable[1,1]==obsv[1,1]) {
493 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
494 prof[[classe]][nrow(prof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
495 prof[[classe]][nrow(prof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
496 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)
497 prof[[classe]][nrow(prof[[classe]]),4]<-round(chiresult$statistic,digits=2)
498 prof[[classe]][nrow(prof[[classe]]),5]<-mod.names[ligne]
499 prof[[classe]][nrow(prof[[classe]]),6]<-chiresult$p.value
500 aprof[[classe]][nrow(aprof[[classe]])+1,1]<-as.numeric(x[ligne,classe])
501 aprof[[classe]][nrow(aprof[[classe]]),2]<-as.numeric(as.vector(x[ligne,ncol(x)]))
502 aprof[[classe]][nrow(aprof[[classe]]),3]<-round((as.numeric(x[ligne,classe])/as.numeric(as.vector(x[ligne,ncol(x)])))*100,digits=2)
503 aprof[[classe]][nrow(aprof[[classe]]),4]<--round(chiresult$statistic,digits=2)
504 aprof[[classe]][nrow(aprof[[classe]]),5]<-mod.names[ligne]
505 aprof[[classe]][nrow(aprof[[classe]]),6]<-chiresult$p.value
508 if (conttable[1,1]>obsv[1,1]) {
509 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
510 } else if (conttable[1,1]<obsv[1,1]){
511 tablesqr[ligne,classe]<--round(chiresult$statistic,digits=3)
513 #pour gerer le cas avec une seule v et par exemple
514 else if (conttable[1,1]==obsv[1,1]) {
515 tablesqr[ligne,classe]<-round(chiresult$statistic,digits=3)
521 for (classe in 1:clusternb) {
522 if (length(prof[[classe]])!=0) {
523 prof[[classe]]<-prof[[classe]][order(prof[[classe]][,4],decreasing=TRUE),]
525 if (length(aprof[[classe]])!=0) {
526 aprof[[classe]]<-aprof[[classe]][order(aprof[[classe]][,4]),]
531 output[[2]]<-tablesqr