X-Git-Url: http://iramuteq.org/git?p=iramuteq;a=blobdiff_plain;f=Rlib%2FtextometrieR%2FR%2Fspecificites.R;fp=Rlib%2FtextometrieR%2FR%2Fspecificites.R;h=0426549598f131beb6d54912ef58036bf90a55a1;hp=0000000000000000000000000000000000000000;hb=1a995a6ca4e8dbb09c8b9ab1276dabf17e065f0d;hpb=4045d224033dfcdad2f00d2ebd86a9026c32fca2 diff --git a/Rlib/textometrieR/R/specificites.R b/Rlib/textometrieR/R/specificites.R new file mode 100644 index 0000000..0426549 --- /dev/null +++ b/Rlib/textometrieR/R/specificites.R @@ -0,0 +1,201 @@ +#* Textometrie +#* ANR project ANR-06-CORP-029 +#* http://textometrie.ens-lsh.fr/ +#* +#* 2008 (C) Textometrie project +#* BSD New and Simplified BSD licenses +#* http://www.opensource.org/licenses/bsd-license.php + +## Sylvain Loiseau + +`specificites` <- +function(lexicaltable, types=NULL, parts=NULL) { + spe <- specificites.probabilities(lexicaltable, types, parts); + spelog <- matrix(0, nrow=nrow(spe), ncol=ncol(spe)); + spelog[spe < 0.5] <- log10(spe[spe < 0.5]); + spelog[spe > 0.5] <- abs(log10(1 - spe[spe > 0.5])); + spelog[spe == 0.5] <- 0; + spelog[is.infinite(spe)] <- 0; + spelog <- round(spelog, digits=4); + rownames(spelog) <- rownames(spe); + colnames(spelog) <- colnames(spe); + #class(spelog) <- "specificites"; + #attr(spelog, "l.t") <- spe; + return(spelog); +} + +`specificites.probabilities` <- +function(lexicaltable, types=NULL, parts=NULL) { + + # if (!is.numeric(lexicaltable)) stop("The lexical table must contain numeric values."); + + rowMargin <- rowSums(lexicaltable); # or "F" (the total frequency of all the types). + colMargin <- colSums(lexicaltable); # or "T" (the size of the parts). + F <- sum(lexicaltable); # The grand total (number of tokens in the corpus). + + if (! is.null(types)) { # Filter on tokens to be considered. + if(is.character(types)) { # convert the name of types given with "types" into row index numbers. + if (is.null(rownames(lexicaltable))) stop("The lexical table has no row names and the \"types\" argument is a character vector."); + if (! all(types %in% rownames(lexicaltable))) stop(paste( + "Some requested types are not known in the lexical table: ", + paste(types[! (types %in% rownames(lexicaltable))], collapse=" ")) + ); + } else { + if (any(types < 1)) stop("The row index must be greater than 0."); + if (max(types) > nrow(lexicaltable)) stop("Row index must be smaller than the number of rows."); + } + lexicaltable <- lexicaltable[types,, drop = FALSE]; + rowMargin <- rowMargin[types]; + } + + if (! is.null(parts)) { # Filter on parts to be considered. + if(is.character(parts)) { # convert the name of parts given with "parts" into col index numbers. + if (is.null(colnames(lexicaltable))) stop("The lexical table has no col names and the \"parts\" argument is a character vector."); + if (! all(parts %in% colnames(lexicaltable))) stop(paste( + "Some requested parts are not known in the lexical table: ", + paste(parts[! (parts %in% colnames(lexicaltable))], collapse=" ")) + ); + } else { + if (max(parts) > ncol(lexicaltable)) stop("Column index must be smaller than the number of cols."); + if (any(parts < 1)) stop("The col index must be greater than 0."); + } + lexicaltable <- lexicaltable[,parts, drop=FALSE]; + colMargin <- colMargin[parts]; + } + + if (nrow(lexicaltable) == 0 | ncol(lexicaltable) == 0) { + stop("The lexical table must contains at least one row and one column."); + } + + specif <- matrix(0.0, nrow=nrow(lexicaltable), ncol=ncol(lexicaltable)); + + for(i in 1:ncol(lexicaltable)) { # We proceed the whole lexical table by column (i.e. by part). + + whiteDrawn <- lexicaltable[,i]; # The frequencies observed in this part for each type. + white <- rowMargin; # The total frequencies in the corpus for each type. + black <- F-white; # The total complement frequency in the corpus for each type. + drawn <- colMargin[i]; # The number of tokens in the part. + + independance <- (white * drawn) / F; # The theoretic frequency of each type. + specif_negative <- whiteDrawn < independance; # index of observed frequencies below the theoretic frequencies. + specif_positive <- whiteDrawn >= independance; # index of observed frequencies above the theoretic frequencies. + + specif[specif_negative,i] <- phyper ( + whiteDrawn[specif_negative], white[specif_negative], black[specif_negative], drawn + ); + + specif[specif_positive,i] <- phyper ( + whiteDrawn[specif_positive] - 1, white[specif_positive], black[specif_positive], drawn + ); + } + + dimnames(specif) <- dimnames(lexicaltable); + + return(specif); +} + +`specificites.lexicon` <- +function(lexicon, sublexicon) { + spe <- specificites.lexicon.probabilities(lexicon, sublexicon); + spelog <- matrix(0, nrow=nrow(spe), ncol=ncol(spe)); + spelog[spe < 0.5] <- log10(spe[spe < 0.5]); + spelog[spe > 0.5] <- abs(log10(1 - spe[spe > 0.5])); + spelog[spe == 0.5] <- 0; + spelog[is.infinite(spe)] <- 0; + spelog <- round(spelog, digits=4); + rownames(spelog) <- rownames(spe); + colnames(spelog) <- colnames(spe); + #class(spelog) <- "specificites"; + #attr(spelog, "l.t") <- spe; + return(spelog); +} + +`specificites.lexicon.new` <- +function(lexicon, sublexicon) { + + if (! all(names(sublexicon) %in% names(lexicon))) stop( + paste( + sum(! (names(sublexicon) %in% names(lexicon))), + "types of the sublexicon not found in the lexicon: ", + ) + ); + +sub <- numeric(length(lexicon)); +names(sub) <- names(lexicon); +sub[names(sublexicon)] <- sublexicon; + + complementary.lexicon <- c(lexicon- sub); + if (any(complementary.lexicon < 0)) stop("type cannot be more frequent in the sublexicon than in the lexicon"); + + lexicaltable <- matrix(c(sub, complementary.lexicon), ncol=2); + rownames(lexicaltable) <- names(lexicon); + colnames(lexicaltable) <- c("sublexicon", "complementary"); + #stop(colnames(lexicaltable)); + return(specificites(lexicaltable,NULL,NULL)); +} + +`specificites.lexicon.probabilities` <- +function(lexicon, sublexicon) { + + if (!is.numeric(lexicon)) stop("The lexicon must contain numeric values."); + if (!is.numeric(sublexicon)) stop("The sublexicon must contain numeric values."); + if (is.null(names(lexicon))) stop("The lexicon must contain names."); + if (is.null(names(sublexicon))) stop("The sub lexicon must contain names."); + + if (! all(names(sublexicon) %in% names(lexicon))) + stop( + paste( + "Some requested types of the sublexicon are not known in the lexicon: ", + paste(names(sublexicon)[! (names(sublexicon) %in% names(lexicon))], collapse=" ") + ) + ); + + F <- sum(lexicon); + f <- sum(sublexicon); + + # complementary.lexicon <- c(lexicon[names(sublexicon)] - sublexicon, lexicon[!names(lexicon) %in% names(sublexicon)]); + + if (F < f) { + stop("The lexicon cannot be smaller than the sublexicon"); + } + + whiteDrawn <- numeric(length(lexicon)); # The frequencies observed in this part for each type. + names(whiteDrawn) <- names(lexicon); + whiteDrawn[names(sublexicon)] <- sublexicon; + white <- lexicon; # The total frequencies in the corpus for each type. + black <- F-white; # The total complement frequency in the corpus for each type. + drawn <- f; # The number of tokens in the part. + + # print(whiteDrawn); + # print(white); + # print(black); + # print(drawn); + + independance <- (white * drawn) / F; # The theoretic frequency of each type. + + specif_negative <- whiteDrawn < independance; # index of observed frequencies below the theoretic frequencies. + specif_positive <- whiteDrawn >= independance; # index of observed frequencies above the theoretic frequencies. + + specif <- double(length(lexicon)); + + specif[specif_negative] <- phyper ( + whiteDrawn[specif_negative], white[specif_negative], black[specif_negative], drawn + ); + + specif[specif_positive] <- phyper ( + whiteDrawn[specif_positive] - 1, white[specif_positive], black[specif_positive], drawn + ); + + names(specif) <- names(lexicon); + + return(specif); +} + +#print.specificites(x, line=20, part=1, form=NULL, ...) { +# if (all(is.null(line, part))) { +# stop("either a line or a part must be specified"); +# } +# if (all(!is.null(line, part))) { +# stop("only a line or a part must be specified"); +# } +#}