mclustcomp/0000755000176200001440000000000015064174242012445 5ustar liggesusersmclustcomp/MD50000644000176200001440000000221115064174242012751 0ustar liggesusersd10766f2317a35776f99a7a8593dab09 *DESCRIPTION 5614e0c31a66164fa198efa05fa0ec5f *LICENSE 269b36c2dec1439b14d921aca4cabcde *NAMESPACE 1d1beba0b157bf4da05dd693085a1b95 *NEWS.md 40f8b68f35151f53c0ff471d76a036fc *R/RcppExports.R 68ec5e4ade137d3adf3d9c783c097e87 *R/auxiliary.R 666e0c713303cff8571f9a062012dc43 *R/cat1_CountingPairs.R 9c21a3bf76755ba99c782681d0826617 *R/cat2_SetOverlap.R e8405e53f81634794f9be122ea12c4bc *R/cat3_InfoTheory.R e957dbd4db81233c51deef863ec299e0 *R/mclustcomp.R f3a2b9df8f4a59b1df1af6863aa4da6d *R/package-mclustcomp.R 253343ba565d3afbc92616b6de7e9ef1 *README.md 3708c35a54e8f31535f478d385a669ff *build/partial.rdb 5edcfe1b071040fed2a3ffce3ae01482 *inst/REFERENCES.bib acfc9740d5a382344e1906d91232591e *man/get.commsize.Rd 0270fbdf9958607e4e5ff7c38de54b53 *man/get.pair.Rd 243c2874cc4b5c2afeab1a77c0b00fd3 *man/get.probs.Rd cae0331ccd4e1595db340ca8e8025207 *man/mclustcomp.Rd 8ac26a2715d4cd4614c9eb5b662ce0ce *src/Makevars 6a30068e0a46e088358abca5df62b6a1 *src/Makevars.win ef4c5702d63b55e4379d45cb82627f9a *src/RcppExports.cpp 6e049bc3d4d41edf5c2a5bdfe36d2181 *src/auxiliary.cpp 659015299802033474ba9cda7fe799f3 *src/auxiliary_arma.cpp mclustcomp/R/0000755000176200001440000000000015064122461012642 5ustar liggesusersmclustcomp/R/RcppExports.R0000644000176200001440000000142115064122461015254 0ustar liggesusers# Generated by using Rcpp::compileAttributes() -> do not edit by hand # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #' Compute community size of a clustering #' #' @keywords internal get.commsize <- function(x, ux) { .Call('_mclustcomp_getcommsize', PACKAGE = 'mclustcomp', x, ux) } #' Comembership matrix of size \code{(2-by-2)} #' #' @keywords internal get.pair <- function(x, y) { .Call('_mclustcomp_getpair', PACKAGE = 'mclustcomp', x, y) } #' Compute confusion matrix #' #' @keywords internal get.probs <- function(confmat, scx, scy, n, threps) { .Call('_mclustcomp_getprobs', PACKAGE = 'mclustcomp', confmat, scx, scy, n, threps) } get.confusion <- function(x, y, ux, uy) { .Call('_mclustcomp_genconfusion', PACKAGE = 'mclustcomp', x, y, ux, uy) } mclustcomp/R/cat3_InfoTheory.R0000644000176200001440000000510715064122220015761 0ustar liggesusers## CAT3 : Information Theory # 12. single12_mi : Mutual Information # 13. single13_nmi1 : NMI by Strehl & Ghosh # 14. single14_nmi2 : NMI by Fred & Jain # 15. single15_vi : Variation of Information # 23. single23_jent : Joint Entropy # 24. single24_nmi3 : NMI by Danon # 25. single25_nvi : Normalized Variation of Information # 12. single12_mi --------------------------------------------------------- #' @keywords internal #' @noRd single12_mi <- function(Ixy){ return(Ixy) } # 13. single13_nmi1 ------------------------------------------------------- #' @keywords internal #' @noRd single13_nmi1 <- function(Ixy,Hx,Hy,threps){ correct = min(threps) altthr = c(threps,1e-10) denom = sqrt(Hx*Hy) if (denom(1-correct)){output = 1} return(output) } # 14. single14_nmi2 ------------------------------------------------------- #' @keywords internal #' @noRd single14_nmi2 <- function(Ixy,Hx,Hy,threps){ correct = min(threps) altthr = c(threps,1e-10) denom = Hx+Hy if (denom(1-correct)){output = 1} return(output) } # 15. single15_vi --------------------------------------------------------- #' @keywords internal #' @noRd single15_vi <- function(Ixy,Hx,Hy,threps){ correct = min(threps) # 1. prep altthr = c(threps,1e-10) if (Hx. #' #' @noRd #' @name mclustcomp-package #' @import Rdpack #' @importFrom Rcpp evalCpp #' @useDynLib mclustcomp NULL mclustcomp/R/cat2_SetOverlap.R0000644000176200001440000000405315064122220015755 0ustar liggesusers## CAT2 : Set Overlaps/Matching # 08. single08_f : F-Measure # 09. single09_mhm : Meila-Heckerman Measure # 10. single10_mmm : Maximum-Match Measure # 11. single11_vdm : Van Dongen Measure # 08. single08_f ---------------------------------------------------------- #' @keywords internal #' @noRd single08_f <- function(scx,scy,n){ # # 1. preliminary # kk = length(scx) # ll = length(scy) # # # 2. computation # output = 0 # for (i in 1:kk){ # tx = scx[i] # vecvaly = (2*tx*scy)/(tx+scy) # output = output + (tx*max(vecvaly)) # } # output = output/n # return(output) # 1. preliminary nx = length(scx) ny = length(scy) # 2. matrix entries fij = array(0, c(nx, ny)) for (i in 1:nx){ ci = scx[i] for (j in 1:ny){ cj = scy[j] fij[i,j] = 2*ci*cj/(ci+cj) } } # 3. compute output = 0 for (i in 1:nx){ # output = output + (max(as.vector(fij[i,]))*scx[i]/n) output = output + (max(as.vector(fij[i,]))*scx[i]/base::sum(scx)) } return(output) } # 09. single09_mhm -------------------------------------------------------- #' @keywords internal #' @noRd single09_mhm <- function(confmat, n){ # 1. get size kk = dim(confmat)[1] # 2. compute output = 0 for (i in 1:kk){ output = output+max(confmat[i,]) } output = output/n return(output) } # 10. single10_mmm -------------------------------------------------------- #' @keywords internal #' @noRd single10_mmm <- function(confmat,n,nk,nl){ # 1. preprocessing minsize = min(nk,nl) # 2. iteration output = 0 for (i in 1:minsize){ output = output + max(confmat[i,]) } # 3. return output = output/n return(output) } # 11. single11_vdm -------------------------------------------------------- #' @keywords internal #' @noRd single11_vdm <- function(confmat,n){ # 1. preliminary nk = nrow(confmat) nl = ncol(confmat) # 2. iteration output = 2*n for (i in 1:nk){ output = output-max(confmat[i,]) } for (j in 1:nl){ output = output-max(confmat[,j]) } return(output) } mclustcomp/R/auxiliary.R0000644000176200001440000000063315064122220014767 0ustar liggesusers# AUXILIARY FUNCTIONS # 1. conversion : input type conversion # 1. aux.conversion ------------------------------------------------------- #' @keywords internal #' @noRd aux.conversion <- function(x){ if (is.character(x)){ x = as.numeric(as.factor(unlist(strsplit(x,split="")))) } else if (is.factor(x)){ x = as.numeric(x) } else { x = as.numeric(as.factor(x)) } return(round(x)) } mclustcomp/R/cat1_CountingPairs.R0000644000176200001440000001154115064122220016455 0ustar liggesusers## CAT1 : Counting Pairs # 01. single01_chisq : Chi-Squared Coefficient # 02. single02_rand : Rand Index # 03. single03_adjrand : Adjusted Rand Index # 04. single04_fmi : Fowlkes-Mallows Index # 05. single05_mirkin : Mirkin Metric # 06. single06_jaccard : Jaccard Index # 07. single07_pd : Partition Difference # 16. single16_wallace1 : Wallace Criterion Type 1 # 17. single17_wallace2 : Wallace Criterion Type 2 # 18. single18_overlap : Overlap Coefficient # 19. single19_sdc : Sorensen-Dice Coefficient # 20. single20_smc : Simple Matching Coefficient # 22. single22_tversky : Tversky Index # 01. single01_chisq ------------------------------------------------------ #' @keywords internal #' @noRd single01_chisq <- function(confmat, scx, scy, n){ # 1. preliminary nx = length(scx) ny = length(scy) # 2. main computation output = 0 for (i in 1:nx){ for (j in 1:ny){ m_ij = confmat[i,j] e_ij = scx[i]*scy[j]/n output = output+ ((m_ij-e_ij)^2)/e_ij } } return(output) } # 02. single02_rand ------------------------------------------------------- #' @keywords internal #' @noRd single02_rand <- function(pairmat, n){ n11 = pairmat[2,2] n00 = pairmat[1,1] output = (2*(n00+n11))/(n*(n-1)) return(output) } # 03. single03_adjrand ---------------------------------------------------- #' @keywords internal #' @noRd single03_adjrand <- function(confmat,scx,scy,n){ # 1-1. preprocessing nk = length(scx) nl = length(scy) # 1-2. computing basic elements t1 = 0 for (i in 1:nk){ tx = scx[i] t1 = t1+ (tx*(tx-1))/2 } t2 = 0 for (j in 1:nl){ ty = scy[j] t2 = t2+ (ty*(ty-1))/2 } t3 = (2*t1*t2)/(n*(n-1)) summ = 0 for (i in 1:nk){ for (j in 1:nl){ tgt = confmat[i,j] summ = summ+(tgt*(tgt-1))/2 } } # 1-3. gathering up output = (summ-t3)/(((t1+t2)/2)-t3) return(output) } # 04. single04_fmi -------------------------------------------------------- #' @keywords internal #' @noRd single04_fmi <- function(pairmat){ # 4-1. separate n11 = pairmat[1,1] n01 = pairmat[2,1] n10 = pairmat[1,2] # 4-2. compute output = n11/sqrt((n11+n10)*(n11+n01)) return(output) } # 05. single05_mirkin ----------------------------------------------------- #' @keywords internal #' @noRd single05_mirkin <- function(confmat, scx, scy){ # 1. preliminary nk = length(scx) nl = length(scy) # 2. main iteration output = sum((scx^2)) + sum((scy^2)) for (i in 1:nk){ for (j in 1:nl){ tgt = confmat[i,j] output = output - (2*(tgt^2)) } } return(output) } # 06. single06_jaccard ---------------------------------------------------- #' @keywords internal #' @noRd single06_jaccard <- function(pairmat){ # 1. separate n11 = pairmat[1,1] n01 = pairmat[2,1] n10 = pairmat[1,2] # 2. compute output = n11/(n11+n10+n01) return(output) } # 07. single07_pd --------------------------------------------------------- #' @keywords internal #' @noRd single07_pd <- function(pairmat){ output = pairmat[2,2] return(output) } # 16. single16_wallace1 --------------------------------------------------- #' @keywords internal #' @noRd single16_wallace1 <- function(pairmat, scx){ n11 = pairmat[1,1] denom = sum((scx*(scx-1))/2) return(n11/denom) } # 17. single17_wallace2 --------------------------------------------------- #' @keywords internal #' @noRd single17_wallace2 <- function(pairmat, scy){ n11 = pairmat[1,1] denom = sum((scy*(scy-1))/2) return(n11/denom) } # 18. single18_overlap ---------------------------------------------------- #' @keywords internal #' @noRd single18_overlap <- function(pairmat){ x = pairmat[1,1]+pairmat[1,2] y = pairmat[1,1]+pairmat[2,1] output = pairmat[1,1]/min(x,y) return(output) } # 19. single19_sdc -------------------------------------------------------- #' @keywords internal #' @noRd single19_sdc <- function(pairmat){ TP = pairmat[1,1] FP = pairmat[1,2] FN = pairmat[2,1] output = (2*TP)/((2*TP)+FN+FP) return(output) } # 20. single20_smc -------------------------------------------------------- #' @keywords internal #' @noRd single20_smc <- function(pairmat){ output = (sum(diag(pairmat)))/(sum(pairmat)) return(output) } # 22. single22_tversky ---------------------------------------------------- # Tanimoto Coefficient is special case of Tversky Index with (alpha,beta)=(1,1) # alpha=0.5=beta : Dice's Coefficient / SDC # alpha=1=beta : Tanimoto Coefficient # sym=FALSE : original tversky # sym=TRUE : a variant introduced on Wikipedia #' @keywords internal #' @noRd single22_tversky <- function(pairmat,alpha,beta,sym){ TP = pairmat[1,1] FP = pairmat[1,2] FN = pairmat[2,1] if (!sym){ output = TP/(TP+(alpha*FP)+(beta*FN)) } else { a = min(FP,FN) b = max(FP,FN) output = TP/(TP+(beta*(alpha*a+(1-alpha)*b))) } return(output) } mclustcomp/R/mclustcomp.R0000644000176200001440000002550715064122220015155 0ustar liggesusers#' Measures for Comparing Clusterings #' #' Given two partitions or clusterings \eqn{C_1} and \eqn{C_2}, it returns community comparison scores #' corresponding with a set of designated methods. Note that two label vectors should be #' of same length having either numeric or factor type. Currently we have 3 classes of methods #' depending on methodological philosophy behind each. See below for the taxonomy. #' #' @section Category 1. Counting Pairs: #' \tabular{cl}{ #' TYPE \tab FULL NAME \cr #' \code{'adjrand'} \tab \href{https://en.wikipedia.org/wiki/Rand_index}{Adjusted Rand index}.\cr #' \code{'chisq'} \tab \href{https://en.wikipedia.org/wiki/Chi-squared_test}{Chi-Squared Coefficient}.\cr #' \code{'fmi'} \tab \href{https://en.wikipedia.org/wiki/Fowlkes-Mallows_index}{Fowlkes-Mallows index}.\cr #' \code{'jaccard'} \tab \href{https://en.wikipedia.org/wiki/Jaccard_index}{Jaccard index}.\cr #' \code{'mirkin'} \tab Mirkin Metric, or Equivalence Mismatch Distance. \cr #' \code{'overlap'} \tab \href{https://en.wikipedia.org/wiki/Overlap_coefficient}{Overlap Coefficient}, or Szymkiewicz-Simpson coefficient.\cr #' \code{'pd'} \tab Partition Difference.\cr #' \code{'rand'} \tab \href{https://en.wikipedia.org/wiki/Rand_index}{Rand Index}.\cr #' \code{'sdc'} \tab \href{https://en.wikipedia.org/wiki/Sorensen-Dice_coefficient}{Sørensen–Dice Coefficient}.\cr #' \code{'smc'} \tab \href{https://en.wikipedia.org/wiki/Simple_matching_coefficient}{Simple Matching Coefficient}.\cr #' \code{'tanimoto'} \tab \href{https://en.wikipedia.org/wiki/Jaccard_index}{Tanimoto index}.\cr #' \code{'tversky'} \tab \href{https://en.wikipedia.org/wiki/Tversky_index}{Tversky index}.\cr #' \code{'wallace1'} \tab Wallace Criterion Type 1.\cr #' \code{'wallace2'} \tab Wallace Criterion Type 2. #' } #' Note that Tanimoto Coefficient and Dice's coefficient are special cases with (alpha,beta) = (1,1) and (0.5,0.5), respectively. #' #' @section Category 2. Set Overlaps/Matching: #' \tabular{cl}{ #' TYPE \tab FULL NAME \cr #' \code{'f'} \tab F-Measure. \cr #' \code{'mhm'} \tab Meila-Heckerman Measure. \cr #' \code{'mmm'} \tab Maximum-Match Measure. \cr #' \code{'vdm'} \tab Van Dongen Measure. #' } #' #' @section Category 3. Information Theory: #' \tabular{cl}{ #' TYPE \tab FULL NAME \cr #' \code{'jent'} \tab \href{https://en.wikipedia.org/wiki/Joint_entropy}{Joint Entropy} \cr #' \code{'mi'} \tab Mutual Information. \cr #' \code{'nmi1'} \tab \href{https://en.wikipedia.org/wiki/Mutual_information}{Normalized Mutual Information} by Strehl and Ghosh. \cr #' \code{'nmi2'} \tab \href{https://en.wikipedia.org/wiki/Mutual_information}{Normalized Mutual Information} by Fred and Jain. \cr #' \code{'nmi3'} \tab Normalized Mutual Information by Danon et al. \cr #' \code{'nvi'} \tab Normalized Variation of Information. \cr #' \code{'vi'} \tab \href{https://en.wikipedia.org/wiki/Variation_of_information}{Variation of Information}. #' } #' #' @param x,y vectors of clustering labels #' @param types \code{"all"} for returning scores for every available measure. #' Either a single score name or a vector of score names can be supplied. See the section #' for the list of the methods for details. #' @param tversky.param a list of parameters for Tversky index; \code{alpha} and \code{beta} for #' weight parameters, and \code{sym}, a logical where \code{FALSE} stands for original method, \code{TRUE} #' for a revised variant to symmetrize the score. Default (alpha,beta)=(1,1). #' #' @return a data frame with columns \code{types} and corresponding \code{scores}. #' #' @examples #' ## example 1. compare two identical clusterings #' x = sample(1:5,20,replace=TRUE) # label from 1 to 5, 10 elements #' y = x # set two labels x and y equal #' mclustcomp(x,y) # show all results #' #' ## example 2. selection of a few methods #' z = sample(1:4,20,replace=TRUE) # generate a non-trivial clustering #' cmethods = c("jaccard","tanimoto","rand") # select 3 methods #' mclustcomp(x,z,types=cmethods) # test with the selected scores #' #' ## example 3. tversky.param #' tparam = list() # create an empty list #' tparam$alpha = 2 #' tparam$beta = 3 #' tparam$sym = TRUE #' mclustcomp(x,z,types="tversky") # default set as Tanimoto case. #' mclustcomp(x,z,types="tversky",tversky.param=tparam) #' #' #' @references #' \insertRef{strehl_cluster_2003}{mclustcomp} #' #' \insertRef{meila_comparing_2007}{mclustcomp} #' #' \insertRef{goos_comparing_2003}{mclustcomp} #' #' \insertRef{wagner_comparing_2007}{mclustcomp} #' #' \insertRef{albatineh_similarity_2006}{mclustcomp} #' #' \insertRef{mirkin_eleven_2001}{mclustcomp} #' #' \insertRef{rand_objective_1971}{mclustcomp} #' #' \insertRef{kuncheva_using_2004}{mclustcomp} #' #' \insertRef{fowlkes_method_1983}{mclustcomp} #' #' \insertRef{dongen_performance_2000}{mclustcomp} #' #' \insertRef{jaccard_distribution_1912}{mclustcomp} #' #' \insertRef{li_combining_2010}{mclustcomp} #' #' \insertRef{larsen_fast_1999}{mclustcomp} #' #' \insertRef{meila_experimental_2001}{mclustcomp} #' #' \insertRef{cover_elements_2006}{mclustcomp} #' #' \insertRef{ana_robust_2003}{mclustcomp} #' #' \insertRef{wallace_comment_1983}{mclustcomp} #' #' \insertRef{simpson_mammals_1943}{mclustcomp} #' #' \insertRef{dice_measures_1945}{mclustcomp} #' #' \insertRef{segaran_programming_2007}{mclustcomp} #' #' \insertRef{tversky_features_1977}{mclustcomp} #' #' \insertRef{danon_comparing_2005}{mclustcomp} #' #' \insertRef{lancichinetti_detecting_2009}{mclustcomp} #' #' @export mclustcomp <- function(x,y,types="all",tversky.param=list()){ #------------------------------------------------------------------------ ## PREPROCESSING # 1. size argument if ((!is.vector(x))||(!is.vector(y))){ stop("* mclustcomp : input 'x' and 'y' should both be a vector of class labels.") } n = length(x) if (length(y)!=n){ stop("* mclustcomp : two vectors should be of same size.") } # 2. type conversion and unique vector x = aux.conversion(x) y = aux.conversion(y) ux = unique(x) uy = unique(y) if (length(ux)==1){ warning("* mclustcomp : 'x' is a trivial clustering.") } if (length(uy)==1){ warning("* mclustcomp : 'y' is a trivial clustering.") } if (length(ux)==n){ warning("* mclustcomp : 'x' is the singleton clustering.") } if (length(uy)==n){ warning("* mclustcomp : 'y' is the singleton clustering.") } # 3. tversky parameter listdot = as.list(environment()) if ("tversky.param" %in% names(listdot)){ tversky.param = listdot$tversky.param } else { tversky.param = list() } if (!("alpha" %in% names(tversky.param))){tversky.param$alpha = 1} if (!("beta" %in% names(tversky.param))){tversky.param$beta = 1} if (!("sym" %in% names(tversky.param))){tversky.param$sym = FALSE} if (tversky.param$alpha < 0){stop("* mclustcomp : tversky.param$alpha should be >= 0.")} if (tversky.param$beta < 0){stop("* mclustcomp : tversky.param$beta should be >= 0.")} if (!is.logical(tversky.param$sym)){stop("* mclustcomp : tversky.param$sym should be a logical variable; FALSE for original Tversky index, TRUE for a variant.")} #------------------------------------------------------------------------ ## PRELIMINARY COMPUTATIONS ## Prelim1 : CONFUSION MATRIX of size(length(ux),length(uy)) confmat = get.confusion(x,y,ux,uy) ## Prelim2 : size of each cluster scx = get.commsize(x,ux) scy = get.commsize(y,uy) ## Prelim3 : comembership matrix of (2,2) pairmat = get.pair(x,y) ## Prelim4 : probability-related stuffs for Mutual Information threps = min(1e-10,10*(.Machine$double.eps)) probs = get.probs(confmat,scx,scy,n,threps) ## Control : type.out ## Case 1 : Single Argument ## {"all" or single name} ## Case 2 : a vector of names; c("f","rand") type_allnames = c("adjrand","chisq","f","fmi","jaccard","mhm","mirkin","mmm", "mi","nmi1","nmi2","nmi3","overlap","pd","rand","sdc","smc","tanimoto", "tversky","vdm","vi","wallace1","wallace2","jent","nvi") type_out = unique(types) if ("all" %in% type_out){ type_test = sort(type_allnames) } else { type_test = sort(type_out) # this type test is the one we should generate again } #------------------------------------------------------------------------ ## MAIN COMPUTATION type_score = rep(0,length(type_test)) for (i in 1:length(type_test)){ type_score[i] = mclustsingle(n,x,y,ux,uy,scx,scy,confmat,pairmat,probs,threps,type_test[i],tversky.param) } #------------------------------------------------------------------------ ## RETURN RESULTS result = data.frame(types=type_test,scores=type_score) return(result) } # COMPUTE :: single measure branching ------------------------------------- ## Original Implementation of 19 methods mclustsingle <- function(n,x,y,ux,uy,scx,scy,confmat,pairmat,probs,threps,type,tversky.param){ # Missing parameters for score08_mmm nk = length(scx) nl = length(scy) # Sepearting probs for NMI and VIs Ixy = probs$Ixy Hx = probs$Hx Hy = probs$Hy Pxy = (confmat/n) # joint probability matrix + correction Pxy[(Pxy do not edit by hand // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 #include #include using namespace Rcpp; #ifdef RCPP_USE_GLOBAL_ROSTREAM Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); #endif // getcommsize NumericVector getcommsize(NumericVector x, NumericVector ux); RcppExport SEXP _mclustcomp_getcommsize(SEXP xSEXP, SEXP uxSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type ux(uxSEXP); rcpp_result_gen = Rcpp::wrap(getcommsize(x, ux)); return rcpp_result_gen; END_RCPP } // getpair NumericMatrix getpair(NumericVector x, NumericVector y); RcppExport SEXP _mclustcomp_getpair(SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); Rcpp::traits::input_parameter< NumericVector >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(getpair(x, y)); return rcpp_result_gen; END_RCPP } // getprobs List getprobs(NumericMatrix confmat, NumericVector scx, NumericVector scy, const int n, double threps); RcppExport SEXP _mclustcomp_getprobs(SEXP confmatSEXP, SEXP scxSEXP, SEXP scySEXP, SEXP nSEXP, SEXP threpsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< NumericMatrix >::type confmat(confmatSEXP); Rcpp::traits::input_parameter< NumericVector >::type scx(scxSEXP); Rcpp::traits::input_parameter< NumericVector >::type scy(scySEXP); Rcpp::traits::input_parameter< const int >::type n(nSEXP); Rcpp::traits::input_parameter< double >::type threps(threpsSEXP); rcpp_result_gen = Rcpp::wrap(getprobs(confmat, scx, scy, n, threps)); return rcpp_result_gen; END_RCPP } // genconfusion arma::mat genconfusion(arma::vec& x, arma::vec& y, arma::vec& ux, arma::vec& uy); RcppExport SEXP _mclustcomp_genconfusion(SEXP xSEXP, SEXP ySEXP, SEXP uxSEXP, SEXP uySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; Rcpp::traits::input_parameter< arma::vec& >::type x(xSEXP); Rcpp::traits::input_parameter< arma::vec& >::type y(ySEXP); Rcpp::traits::input_parameter< arma::vec& >::type ux(uxSEXP); Rcpp::traits::input_parameter< arma::vec& >::type uy(uySEXP); rcpp_result_gen = Rcpp::wrap(genconfusion(x, y, ux, uy)); return rcpp_result_gen; END_RCPP } static const R_CallMethodDef CallEntries[] = { {"_mclustcomp_getcommsize", (DL_FUNC) &_mclustcomp_getcommsize, 2}, {"_mclustcomp_getpair", (DL_FUNC) &_mclustcomp_getpair, 2}, {"_mclustcomp_getprobs", (DL_FUNC) &_mclustcomp_getprobs, 5}, {"_mclustcomp_genconfusion", (DL_FUNC) &_mclustcomp_genconfusion, 4}, {NULL, NULL, 0} }; RcppExport void R_init_mclustcomp(DllInfo *dll) { R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } mclustcomp/src/Makevars.win0000644000176200001440000000017615064122233015521 0ustar liggesusers## optional PKG_CXXFLAGS = $(SHLIB_OPENMP_CXXFLAGS) PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) mclustcomp/src/auxiliary.cpp0000644000176200001440000001254115064122220015737 0ustar liggesusers// [[Rcpp::depends(RcppArmadillo)]] #include "RcppArmadillo.h" using namespace Rcpp; using namespace arma; /* * Aux 1. compute confusion matrix */ // //' Compute confusion matrix // //' // //' @keywords internal // // [[Rcpp::export("get.confusion")]] // NumericMatrix getconfusion(NumericVector x, NumericVector y, NumericVector ux, NumericVector uy){ // // 1. preprocessing // const int k = ux.length(); // const int l = uy.length(); // const int n = x.length(); // NumericMatrix confmat(k,l); // // // 2. main iteration // for (int it1=0;it10){ Hx -= valx*log(valx)/log2; } } double Hy = 0; for (int j=0;j0){ Hy -= valy*log(valy)/log2; } } double Ixy = 0; for (int i=0;i0)&&(valy>0)&&(valxy>0)){ Ixy += valxy*((log(valxy)-log(valx)-log(valy))/log2); } } } // 4. return List output; output["Hx"] = Hx; output["Hy"] = Hy; output["Ixy"] = Ixy; return output; } // // // List getprobs_old(NumericMatrix confmat, NumericVector scx, NumericVector scy, const int n, double threps){ // // 1. preliminary // const int nk = scx.length(); // const int nl = scy.length(); // NumericVector altthr(2); // altthr[0] = threps; // altthr[1] = 1e-7; // double maxthr = max(altthr); // int warningint = 0; // 1<-Px, 2<-Py, 3<-Pxy // // // 2. compute::basics // NumericVector Px = scx/n; // NumericVector Py = scy/n; // NumericMatrix Pxy = confmat/n; // for (int i=0;i1-threps){ // Px[i] = 1-maxthr; // warningint = 1; // } // } // for (int j=0;j1-threps){ // Py[j] = 1-maxthr; // warningint = 2; // } // } // for (int i=0;i1-threps){ // Pxy(i,j) = 1-maxthr; // warningint = 3; // } // } // } // // // 3. compute::3 measures // double log2 = log(2.0); // double Hx = 0; // for (int i=0;i