@@ -1,4 +1,5 @@

 Package: discordant

+Type: Package

 Version: 1.17.0

 Date: 2016-10-21

 Title: The Discordant Method: A Novel Approach for Differential

@@ -17,12 +18,22 @@ Maintainer: Max McGrath <max.mcgrath@ucdenver.edu>

 Description: Discordant is a method to determine differential

         correlation of molecular feature pairs from -omics data using

         mixture models. Algorithm is explained further in Siska et al.

-Encoding: latin1

-biocViews: ImmunoOncology, BiologicalQuestion, StatisticalMethod, mRNAMicroarray,

-        Microarray, Genetics, RNASeq

-Suggests: BiocStyle, knitr

-Imports: Biobase, stats, biwt, gtools, MASS, tools

+Encoding: UTF-8

+biocViews: ImmunoOncology, BiologicalQuestion, StatisticalMethod, 

+    mRNAMicroarray,

+    Microarray, Genetics, RNASeq

+Suggests: BiocStyle, knitr, testthat

+Imports: 

+    Rcpp,

+    Biobase,

+    stats,

+    biwt,

+    gtools,

+    MASS,

+    tools

 License: GPL (>= 2)

 URL: https://github.com/siskac/discordant

 NeedsCompilation: yes

+LinkingTo: Rcpp

 VignetteBuilder: knitr

+RoxygenNote: 7.1.1

@@ -1,10 +1,14 @@

-useDynLib(discordant, .registration = TRUE)

+# Generated by roxygen2: do not edit by hand

+export(createVectors)

+export(discordantRun)

+export(fishersTrans)

+export(splitMADOutlier)

+import(Biobase)

 import(MASS)

-import(gtools)

 import(biwt)

-import(tools)

+import(gtools)

 import(stats)

-import(Biobase)

-

-export(createVectors, discordantRun, fishersTrans, splitMADOutlier)

+import(tools)

+importFrom(Rcpp,sourceCpp)

+useDynLib(discordant, .registration = TRUE)

new file mode 100644

@@ -0,0 +1,11 @@

+# Generated by using Rcpp::compileAttributes() -> do not edit by hand

+# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

+

+em_normal_partial_concordant_cpp <- function(x, y, zxy, n, pi, mu, sigma, nu, tau, g, loglik, tol, restriction, constrain, iteration, convergence) {

+    .Call(`_discordant_em_normal_partial_concordant_cpp`, x, y, zxy, n, pi, mu, sigma, nu, tau, g, loglik, tol, restriction, constrain, iteration, convergence)

+}

+

+subsampling_cpp <- function(x, y, zxy, n, pi, mu, sigma, nu, tau, g) {

+    .Call(`_discordant_subsampling_cpp`, x, y, zxy, n, pi, mu, sigma, nu, tau, g)

+}

+

new file mode 100644

@@ -0,0 +1,5 @@

+## usethis namespace: start

+#' @useDynLib discordant, .registration = TRUE

+#' @importFrom Rcpp sourceCpp

+## usethis namespace: end

+NULL

\ No newline at end of file

@@ -158,9 +158,11 @@ SparCC.frac <- function(x, kmax = 10, alpha = 0.1, Vmin = 1e-4) {

 #modified from package mclust

-unmap <- function(classification){

+unmap <- function(classification, components){

     n <- length(classification)

-    u <- sort(unique(classification))

+    # u <- sort(unique(classification)) # OG Code

+    # u <- 0:max(classification) # Max's potential fix

+    u <- 0:(components - 1)

     labs <- as.character(u)

     k <- length(u)

     z <- matrix(0, n, k)

@@ -171,7 +173,7 @@ unmap <- function(classification){

 em.normal.partial.concordant <- function(data, class, tol=0.001, 

-    restriction=0, constrain=0, iteration=1000){

+    restriction=0, constrain=0, iteration=1000, components){

     n <- as.integer(dim(data)[1])

     g <- as.integer(nlevels(as.factor(class)))

@@ -182,8 +184,8 @@ em.normal.partial.concordant <- function(data, class, tol=0.001,

         return( c(diag(z[k,])) )

     }

-    zx <- unmap(class[,1])

-    zy <- unmap(class[,2])

+    zx <- unmap(class[,1], components = components)

+    zy <- unmap(class[,2], components = components)

     zxy <- sapply(1:dim(zx)[1], yl.outer, zx, zy)

     pi <- double(g*g)

@@ -193,10 +195,21 @@ em.normal.partial.concordant <- function(data, class, tol=0.001,

     tau <- double(g)

     loglik <- double(1)

     convergence <- integer(1)

-    results <- .C("em_normal_partial_concordant", as.double(data[,1]), 

-        as.double(data[,2]), as.double(t(zxy)), n, pi, mu, sigma, nu, tau, g, 

-        loglik, as.double(tol), as.integer(restriction), 

-        as.integer(constrain), as.integer(iteration), convergence)

+    # results <- .C("em_normal_partial_concordant", as.double(data[,1]), 

+    #     as.double(data[,2]), as.double(t(zxy)), n, pi, mu, sigma, nu, tau, g, 

+    #     loglik, as.double(tol), as.integer(restriction), 

+    #     as.integer(constrain), as.integer(iteration), convergence)

+    

+    results <- em_normal_partial_concordant_cpp(as.double(data[,1]), 

+                                                as.double(data[,2]), 

+                                                as.double(t(zxy)), n, pi, mu, 

+                                                sigma, nu, tau, g, loglik, 

+                                                as.double(tol), 

+                                                as.integer(restriction), 

+                                                as.integer(constrain), 

+                                                as.integer(iteration), 

+                                                convergence)

+    

     return(list(model="PCD", convergence=results[[16]], 

         pi=t(array(results[[5]], dim=c(g,g))), mu_sigma=rbind(results[[6]], 

         results[[7]]), nu_tau=rbind(results[[8]], results[[9]]), 

@@ -204,7 +217,7 @@ em.normal.partial.concordant <- function(data, class, tol=0.001,

         order,decreasing=TRUE)[1,], z=array(results[[3]], dim=c(n,g*g))))

 }

-subSampleData <- function(pdata, class, mu, sigma, nu, tau, pi) {

+subSampleData <- function(pdata, class, mu, sigma, nu, tau, pi, components) {

     n <- as.integer(dim(pdata)[1])

     g <- as.integer(nlevels(as.factor(class)))

@@ -215,19 +228,26 @@ subSampleData <- function(pdata, class, mu, sigma, nu, tau, pi) {

         return( c(diag(z[k,])) )

     }

-    zx <- unmap(class[,1])

-    zy <- unmap(class[,2])

+    zx <- unmap(class[,1], components = components)

+    zy <- unmap(class[,2], components = components)

     zxy <- sapply(1:dim(zx)[1], yl.outer, zx, zy)

-    results <- .C("subsampling", as.double(pdata[,1]), as.double(pdata[,2]), 

-        as.double(t(zxy)), n, as.double(pi), as.double(mu), as.double(sigma), 

-        as.double(nu), as.double(tau), g)

+    # results <- .C("subsampling", as.double(pdata[,1]), as.double(pdata[,2]), 

+    #     as.double(t(zxy)), n, as.double(pi), as.double(mu), as.double(sigma), 

+    #     as.double(nu), as.double(tau), g)

+    

+    results <- subsampling_cpp(as.double(pdata[,1]), as.double(pdata[,2]), 

+                               as.double(t(zxy)), n, as.double(pi), 

+                               as.double(mu), as.double(sigma), as.double(nu), 

+                               as.double(tau), g)

+    

     return(list(pi=t(array(results[[5]],dim=c(g,g))), 

         mu_sigma=rbind(results[[6]], results[[7]]), nu_tau=rbind(results[[8]],

         results[[9]]), class=apply(array(results[[3]], dim=c(n,g*g)),1,order,

         decreasing=TRUE)[1,], z=array(results[[3]], dim=c(n,g*g))))

 } 

+#' @export

 fishersTrans <- function(rho) {

     r = (1+rho)/(1-rho)

     z = 0.5*log(r,base = exp(1))

@@ -280,6 +300,14 @@ checkInputs <- function(x,y,groups = NULL) {

     return(issue)

 }

+#' @import Biobase

+#' @import biwt

+#' @import gtools

+#' @import MASS

+#' @import stats

+#' @import tools

+#' 

+#' @export

 createVectors <- function(x, y = NULL, groups, cor.method = c("spearman")) {

     print(x)

     if(checkInputs(x,y,groups)) {

@@ -362,6 +390,7 @@ createVectors <- function(x, y = NULL, groups, cor.method = c("spearman")) {

     return(list(v1 = statVector1, v2 = statVector2))

 }

+#' @export

 discordantRun <- function(v1, v2, x, y = NULL, transform = TRUE, 

     subsampling = FALSE, subSize = dim(x)[1], iter = 100, components = 3) {

@@ -458,7 +487,7 @@ discordantRun <- function(v1, v2, x, y = NULL, transform = TRUE,

             }

             pd <- em.normal.partial.concordant(sub.pdata, sub.class, 

                 tol=0.001, restriction=0, constrain=c(0,-sd(pdata),sd(pdata)),

-                iteration=1000)

+                iteration=1000, components=components)

             total_mu <- total_mu + pd$mu_sigma[1,]

             total_sigma <- total_sigma + pd$mu_sigma[2,]

             total_nu <- total_nu + pd$nu_tau[1,]

@@ -472,13 +501,13 @@ discordantRun <- function(v1, v2, x, y = NULL, transform = TRUE,

         tau <- total_tau/iter

         pi <- total_pi/iter

-        finalResult <- subSampleData(pdata, class, mu, sigma, nu, tau, pi)

+        finalResult <- subSampleData(pdata, class, mu, sigma, nu, tau, pi, components)

         zTable <- finalResult$z

         classVector <- finalResult$class

     } else {

         pd <- em.normal.partial.concordant(pdata, class, tol=0.001, 

             restriction=0, constrain=c(0,-sd(pdata),sd(pdata)), 

-            iteration=1000)

+            iteration=1000, components = components)

         zTable <- pd$z

         classVector <- pd$class

     }

@@ -522,6 +551,7 @@ discordantRun <- function(v1, v2, x, y = NULL, transform = TRUE,

         probMatrix = zTable, loglik = pd$loglik))

 }

+#' @export

 splitMADOutlier <- function(mat, filter0 = TRUE, threshold = 2) {

     if(mode(mat) != "S4") {

         stop("data matrix mat must be type ExpressionSet")

new file mode 100644

@@ -0,0 +1,64 @@

+// Generated by using Rcpp::compileAttributes() -> do not edit by hand

+// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

+

+#include <Rcpp.h>

+

+using namespace Rcpp;

+

+// em_normal_partial_concordant_cpp

+Rcpp::List em_normal_partial_concordant_cpp(Rcpp::NumericVector x, Rcpp::NumericVector y, Rcpp::NumericVector zxy, int n, Rcpp::NumericVector pi, Rcpp::NumericVector mu, Rcpp::NumericVector sigma, Rcpp::NumericVector nu, Rcpp::NumericVector tau, int g, double loglik, double tol, int restriction, Rcpp::NumericVector constrain, int iteration, int convergence);

+RcppExport SEXP _discordant_em_normal_partial_concordant_cpp(SEXP xSEXP, SEXP ySEXP, SEXP zxySEXP, SEXP nSEXP, SEXP piSEXP, SEXP muSEXP, SEXP sigmaSEXP, SEXP nuSEXP, SEXP tauSEXP, SEXP gSEXP, SEXP loglikSEXP, SEXP tolSEXP, SEXP restrictionSEXP, SEXP constrainSEXP, SEXP iterationSEXP, SEXP convergenceSEXP) {

+BEGIN_RCPP

+    Rcpp::RObject rcpp_result_gen;

+    Rcpp::RNGScope rcpp_rngScope_gen;

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type y(ySEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type zxy(zxySEXP);

+    Rcpp::traits::input_parameter< int >::type n(nSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type pi(piSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mu(muSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type sigma(sigmaSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type nu(nuSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type tau(tauSEXP);

+    Rcpp::traits::input_parameter< int >::type g(gSEXP);

+    Rcpp::traits::input_parameter< double >::type loglik(loglikSEXP);

+    Rcpp::traits::input_parameter< double >::type tol(tolSEXP);

+    Rcpp::traits::input_parameter< int >::type restriction(restrictionSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type constrain(constrainSEXP);

+    Rcpp::traits::input_parameter< int >::type iteration(iterationSEXP);

+    Rcpp::traits::input_parameter< int >::type convergence(convergenceSEXP);

+    rcpp_result_gen = Rcpp::wrap(em_normal_partial_concordant_cpp(x, y, zxy, n, pi, mu, sigma, nu, tau, g, loglik, tol, restriction, constrain, iteration, convergence));

+    return rcpp_result_gen;

+END_RCPP

+}

+// subsampling_cpp

+Rcpp::List subsampling_cpp(Rcpp::NumericVector x, Rcpp::NumericVector y, Rcpp::NumericVector zxy, int n, Rcpp::NumericVector pi, Rcpp::NumericVector mu, Rcpp::NumericVector sigma, Rcpp::NumericVector nu, Rcpp::NumericVector tau, int g);

+RcppExport SEXP _discordant_subsampling_cpp(SEXP xSEXP, SEXP ySEXP, SEXP zxySEXP, SEXP nSEXP, SEXP piSEXP, SEXP muSEXP, SEXP sigmaSEXP, SEXP nuSEXP, SEXP tauSEXP, SEXP gSEXP) {

+BEGIN_RCPP

+    Rcpp::RObject rcpp_result_gen;

+    Rcpp::RNGScope rcpp_rngScope_gen;

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type x(xSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type y(ySEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type zxy(zxySEXP);

+    Rcpp::traits::input_parameter< int >::type n(nSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type pi(piSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type mu(muSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type sigma(sigmaSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type nu(nuSEXP);

+    Rcpp::traits::input_parameter< Rcpp::NumericVector >::type tau(tauSEXP);

+    Rcpp::traits::input_parameter< int >::type g(gSEXP);

+    rcpp_result_gen = Rcpp::wrap(subsampling_cpp(x, y, zxy, n, pi, mu, sigma, nu, tau, g));

+    return rcpp_result_gen;

+END_RCPP

+}

+

+static const R_CallMethodDef CallEntries[] = {

+    {"_discordant_em_normal_partial_concordant_cpp", (DL_FUNC) &_discordant_em_normal_partial_concordant_cpp, 16},

+    {"_discordant_subsampling_cpp", (DL_FUNC) &_discordant_subsampling_cpp, 10},

+    {NULL, NULL, 0}

+};

+

+RcppExport void R_init_discordant(DllInfo *dll) {

+    R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);

+    R_useDynamicSymbols(dll, FALSE);

+}

deleted file mode 100644

@@ -1,269 +0,0 @@

-#include <R.h>

-#include <R_ext/Rdynload.h>

-#include <Rinternals.h>

-

-void em_normal_partial_concordant(double *x, double *y, double *zxy, int *n, double *pi, double *mu, double *sigma, double *nu, double *tau, int *g, double *loglik, double *tol, int *restriction, int *constrain, int *iteration, int *convergence) {

-	int i, j, k, flag, iter;

-	double temp, loglik2;

-

-

-	/*theoretical restriction on the null*/

-	if((*restriction)>0){

-	/*initialization*/

-		flag=1;

-		(*loglik) = 0;

-		for(k=0;k<*n;k++){	

-			(*loglik) = (*loglik) - 0.5*x[k]*x[k] - 0.5*log(2*PI) - 0.5*y[k]*y[k] - 0.5*log(2*PI);

-		}

-		/*iteration*/

-		

-		iter = 0;

-		while(flag>0 & iter<(*iteration)){

-		/*M step for pi, mu and sigma*/

-			for(i=0;i<(*g);i++){

-				pi[i] = 0;

-				for(k=0;k<(*n);k++){

-					for(j=0;j<(*g);j++){

-						pi[i] = pi[i] + zxy[(j*(*g)+i)*(*n)+k];

-					}

-				}

-				mu[i] = 0;

-				for(k=0;k<(*n);k++){

-					for(j=0;j<(*g);j++){

-						mu[i] = mu[i] + zxy[(j*(*g)+i)*(*n)+k]*x[k];

-					}

-				}

-				mu[i] = mu[i] / pi[i];

-				sigma[i] = 0;

-				for(k=0;k<(*n);k++){

-					for(j=0;j<(*g);j++){

-						sigma[i] = sigma[i] + zxy[(j*(*g)+i)*(*n)+k]*(x[k]-mu[i])*(x[k]-mu[i]);

-					}

-				}

-				sigma[i] = sigma[i] / pi[i];

-			}

-			for(j=0;j<(*g);j++){

-				pi[j] = 0;

-				for(k=0;k<(*n);k++){

-					for(i=0;i<(*g);i++){

-						pi[j] = pi[j] + zxy[(j*(*g)+i)*(*n)+k];

-					}

-				}

-				nu[j] = 0;

-				for(k=0;k<(*n);k++){

-					for(i=0;i<(*g);i++){

-						nu[j] = nu[j] + zxy[(j*(*g)+i)*(*n)+k]*y[k];

-					}

-				}

-				nu[j] = nu[j] / pi[j];

-				tau[j] = 0;

-				for(k=0;k<(*n);k++){

-					for(i=0;i<(*g);i++){

-						tau[j] = tau[j] + zxy[(j*(*g)+i)*(*n)+k]*(y[k]-nu[j])*(y[k]-nu[j]);

-					}

-				}

-				tau[j] = tau[j] / pi[j];

-			}

-			for(i=0;i<(*g);i++){

-				for(j=0;j<(*g);j++){

-					pi[i*(*g)+j] = 0;

-					for(k=0;k<(*n);k++){

-						pi[i*(*g)+j] = pi[i*(*g)+j] + zxy[(j*(*g)+i)*(*n)+k];

-					}

-					pi[i*(*g)+j] = pi[i*(*g)+j] / (double)(*n);

-				}

-			}

-			/*constrain*/

-			for(i=0;i<(*g);i++){

-				if(constrain[i]==0-1){

-					if(mu[i]>0.0){

-						mu[i]=0.0;

-					}

-					if(nu[i]>0.0){

-						nu[i]=0.0;

-					}

-				}

-				if(constrain[i]==0){

-					mu[i] = 0.0;

-					sigma[i] = 1.0;

-					nu[i] = 0.0;

-					tau[i] = 1.0;

-				}

-				if(constrain[i]==0+1){

-					if(mu[i]<0.0){

-						mu[i]=0.0;

-					}

-					if(nu[i]<0.0){

-						nu[i]=0.0;

-					}

-				}

-			}

-			/*check convergence*/

-			loglik2 = (*loglik);

-			(*loglik) = 0;

-			for(k=0;k<(*n);k++){

-				temp = 0;

-				for(i=0;i<(*g);i++){

-					for(j=0;j<(*g);j++){

-						temp = temp + pi[i*(*g)+j] * ( exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i]) )*( exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]) );

-					}

-				}

-				(*loglik) = (*loglik) + log(temp);

-			}

-			if(fabs((*loglik)-loglik2)<(*tol)){

-				flag = 0;

-			}

-			/*E step for z*/

-			for(k=0;k<(*n);k++){

-				temp = 0;

-				for(i=0;i<(*g);i++){

-					for(j=0;j<(*g);j++){

-						temp = temp + pi[i*(*g)+j] * ( exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i]) )*( exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]) );

-					}

-				}

-				for(i=0;i<(*g);i++){

-					for(j=0;j<(*g);j++){

-						zxy[(j*(*g)+i)*(*n)+k] = pi[i*(*g)+j] * ( exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i]) )*( exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]) )/temp;

-					}

-				}

-			}

-			iter = iter + 1;

-		}

-		(*convergence) = 0;

-		if(iter<(*iteration)){

-			(*convergence) = 1;

-		}

-	}

-	/*no restriction on the null*/

-	else{

-	/*initialization*/

-		flag=1;

-		(*loglik) = 0;

-		for(k=0;k<(*n);k++){

-			(*loglik) = (*loglik) - 0.5*x[k]*x[k] - 0.5*log(2*PI) - 0.5*y[k]*y[k] - 0.5*log(2*PI);

-		}

-		/*iteration*/

-		iter = 0;

-		while(flag>0 & iter<(*iteration)){

-		/*M step for pi, mu and sigma*/

-			for(i=0;i<(*g);i++){

-				pi[i] = 0;

-				for(k=0;k<(*n);k++){

-					for(j=0;j<(*g);j++){

-						pi[i] = pi[i] + zxy[(j*(*g)+i)*(*n)+k];

-					}

-				}

-				mu[i] = 0;

-				for(k=0;k<(*n);k++){

-					for(j=0;j<(*g);j++){

-						mu[i] = mu[i] + zxy[(j*(*g)+i)*(*n)+k]*x[k];

-					}

-				}

-				mu[i] = mu[i] / pi[i];

-				sigma[i] = 0;

-				for(k=0;k<(*n);k++){

-					for(j=0;j<(*g);j++){

-						sigma[i] = sigma[i] + zxy[(j*(*g)+i)*(*n)+k]*(x[k]-mu[i])*(x[k]-mu[i]);

-					}

-				}

-				sigma[i] = sigma[i] / pi[i];

-			}

-			for(j=0;j<(*g);j++){

-				pi[j] = 0;

-				for(k=0;k<(*n);k++){

-					for(i=0;i<(*g);i++){

-						pi[j] = pi[j] + zxy[(j*(*g)+i)*(*n)+k];

-					}

-				}

-				nu[j] = 0;

-				for(k=0;k<(*n);k++){

-					for(i=0;i<(*g);i++){

-						nu[j] = nu[j] + zxy[(j*(*g)+i)*(*n)+k]*y[k];

-					}

-				}

-				nu[j] = nu[j] / pi[j];

-				tau[j] = 0;

-				for(k=0;k<(*n);k++){

-					for(i=0;i<(*g);i++){

-						tau[j] = tau[j] + zxy[(j*(*g)+i)*(*n)+k]*(y[k]-nu[j])*(y[k]-nu[j]);

-					}

-				}

-				tau[j] = tau[j] / pi[j];

-			}

-			for(i=0;i<(*g);i++){

-				for(j=0;j<(*g);j++){

-					pi[i*(*g)+j] = 0;

-					for(k=0;k<(*n);k++){

-						pi[i*(*g)+j] = pi[i*(*g)+j] + zxy[(j*(*g)+i)*(*n)+k];

-					}

-					pi[i*(*g)+j] = pi[i*(*g)+j] / (double)(*n);

-				}

-			}

-			/*check convergence*/

-			loglik2 = (*loglik);

-			(*loglik) = 0;

-			for(k=0;k<(*n);k++){

-				temp = 0;

-				for(i=0;i<(*g);i++){

-					for(j=0;j<(*g);j++){

-						temp = temp + pi[i*(*g)+j] * ( exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i]) )*( exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]) );

-					}

-				}

-				(*loglik) = (*loglik) + log(temp);

-			}

-			if(fabs((*loglik)-loglik2)<(*tol)){

-				flag = 0;

-			}

-			/*E step for z*/

-			for(k=0;k<(*n);k++){

-				temp = 0;

-				for(i=0;i<(*g);i++){

-					for(j=0;j<(*g);j++){

-						temp = temp + pi[i*(*g)+j] * ( exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i]) )*( exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]) );

-					}

-				}

-				for(i=0;i<(*g);i++) {

-					for(j=0;j<(*g);j++){

-						zxy[(j*(*g)+i)*(*n)+k] = zxy[(j*(*g)+i)*(*n)+k] + pi[i*(*g)+j] * ( exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i]) )*( exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]) )/temp;

-					}

-				}

-			}

-			iter = iter + 1;

-		}

-		(*convergence) = 0;

-		if(iter<(*iteration)){

-			(*convergence) = 1;

-		}

-	}

-}

-

-void subsampling(double *x, double *y, double *zxy, int *n, double *pi, double *mu, double *sigma, double *nu, double *tau, int *g) {

-        int i, j, k;

-        double temp;

-        for(k=0;k<(*n);k++){

-                temp = 0;

-                for(i=0;i<(*g);i++){

-                        for(j=0;j<(*g);j++){

-                                temp = temp + pi[i*(*g)+j] * ( exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i]) )*( exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]) );

-                        }

-                }

-                for(i=0;i<(*g);i++) {

-                        for(j=0;j<(*g);j++){

-                                zxy[(j*(*g)+i)*(*n)+k] = zxy[(j*(*g)+i)*(*n)+k] + pi[i*(*g)+j] * ( exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i]) )*( exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]) )/temp;

-                        }

-                }

-        }

-

-}

-

-R_CMethodDef cMethods[]  = {

-  {"em_normal_partial_concordant", (DL_FUNC) &em_normal_partial_concordant, 16},

-  {"subsampling", (DL_FUNC) &subsampling, 11},

-  {NULL, NULL, 0}

-};

-

-void R_init_discordant(DllInfo *info) {

-  R_registerRoutines(info, cMethods, NULL, NULL, NULL);

-  R_useDynamicSymbols(info, FALSE);

-}

-

new file mode 100644

@@ -0,0 +1,190 @@

+#include <Rcpp.h>

+#include <math.h>

+#include <iostream>

+using namespace Rcpp;

+

+// [[Rcpp::export]]

+Rcpp::List em_normal_partial_concordant_cpp(Rcpp::NumericVector x,

+                                        Rcpp::NumericVector y,

+                                        Rcpp::NumericVector zxy,

+                                        int n,

+                                        Rcpp::NumericVector pi,

+                                        Rcpp::NumericVector mu,

+                                        Rcpp::NumericVector sigma,

+                                        Rcpp::NumericVector nu,

+                                        Rcpp::NumericVector tau,

+                                        int g,

+                                        double loglik,

+                                        double tol,

+                                        int restriction,

+                                        Rcpp::NumericVector constrain,

+                                        int iteration,

+                                        int convergence) {

+    int i, j, k, flag, iter;

+    double temp, loglik2;

+    

+    /*initialization*/

+    flag = 1;

+    loglik = 0;

+    for (k = 0; k < n; k++) {

+        loglik = loglik - 0.5*x[k]*x[k] - 0.5*log(2*PI) - 

+            0.5*y[k]*y[k] - 0.5*log(2*PI);

+    }

+    

+    /*iteration*/

+    iter = 0;

+    while (flag > 0 & iter < iteration) {

+

+        /*M step for pi, mu and sigma*/

+        for (i = 0; i < g; i++) {

+            pi[i] = 0;

+            for (k = 0; k < n; k++) {

+                for (j = 0; j < g; j++){

+                    pi[i] = pi[i] + zxy[(j*g+i)*n+k];

+                }

+            }

+            

+            mu[i] = 0;

+            for (k = 0; k < n; k++) {

+                for (j = 0; j < g; j++) {

+                    mu[i] = mu[i] + zxy[(j*g+i)*n+k] * x[k];

+                }

+            }

+            mu[i] = mu[i] / pi[i];

+

+            sigma[i] = 0;

+            for (k = 0; k < n; k++) {

+                for (j = 0; j < g; j++) {

+                    sigma[i] = sigma[i] + zxy[(j*g+i)*n+k] * 

+                        (x[k]-mu[i]) * (x[k]-mu[i]);

+                }

+            }

+            sigma[i] = sigma[i] / pi[i];

+        }

+

+        for (j = 0; j < g; j++) {

+            pi[j] = 0;

+            for (k = 0; k < n; k++) {

+                for (i = 0; i < g; i++) {

+                    pi[j] = pi[j] + zxy[(j*g+i)*n+k];

+                }

+            }

+            

+            nu[j] = 0;

+            for (k = 0; k < n; k++) {

+                for (i = 0; i < g; i++) {

+                    nu[j] = nu[j] + zxy[(j*g+i)*n+k] * y[k];

+                }

+            }

+            nu[j] = nu[j] / pi[j];

+

+            tau[j] = 0;

+            for (k = 0; k < n; k++) {

+                for (i = 0; i < g; i++){

+                    tau[j] = tau[j] + zxy[(j*g+i)*n+k] * 

+                        (y[k]-nu[j]) * (y[k]-nu[j]);

+                }

+            }

+            tau[j] = tau[j] / pi[j];

+        }

+

+        for (i = 0; i < g; i++) {

+            for (j = 0; j < g; j++) {

+                pi[i*g+j] = 0;

+                for (k = 0; k < n; k++) {

+                    pi[i*g+j] = pi[i*g+j] + zxy[(j*g+i)*n+k];

+                }

+                pi[i*g+j] = pi[i*g+j] / static_cast<double>(n);

+            }

+        }

+

+        /* check convergence */

+        loglik2 = loglik;

+        loglik = 0;

+        for (k = 0; k < n; k++) {

+            temp = 0;

+            for (i = 0; i < g; i++) {

+                for (j = 0; j < g; j++) {

+                    temp = temp + pi[i*g+j] * 

+                        (exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i])) * 

+                        (exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]));

+                }

+            }

+            loglik = loglik + log(temp);

+        }

+        

+        if (fabs(loglik-loglik2) < tol){

+            flag = 0;

+        }

+        

+        /*E step for z*/

+        for (k = 0; k < n; k++){

+            temp = 0;

+            for (i = 0; i < g; i++) {

+                for (j = 0; j < g; j++) {

+                    temp = temp + pi[i*g+j] * 

+                        (exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i])) *

+                        (exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]));

+                }

+            }

+            for (i = 0; i < g;i++) {

+                for (j = 0; j < g; j++) {

+                    zxy[(j*g+i)*n+k] = zxy[(j*g+i)*n+k] + pi[i*g+j] * 

+                        (exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i])) *

+                        (exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j])) / temp;

+                }

+            }

+        }

+        iter = iter + 1;

+    

+    }

+

+    convergence = 0;

+    if(iter < iteration) {

+        convergence = 1;

+    }

+    

+    Rcpp::List rtn = Rcpp::List::create(x, y, zxy, n, pi, mu, sigma, nu,

+                                        tau, g, loglik, tol, restriction,

+                                        constrain, iteration, convergence);

+    

+    return rtn;

+}

+

+// [[Rcpp::export]]

+Rcpp::List subsampling_cpp(Rcpp::NumericVector x, 

+                       Rcpp::NumericVector y,

+                       Rcpp::NumericVector zxy,

+                       int n, 

+                       Rcpp::NumericVector pi, 

+                       Rcpp::NumericVector mu, 

+                       Rcpp::NumericVector sigma, 

+                       Rcpp::NumericVector nu, 

+                       Rcpp::NumericVector tau, 

+                       int g) {

+    int i, j, k;

+    double temp;

+    

+    for (k = 0; k < n; k++) {

+        temp = 0;

+        for (i = 0; i < g; i++) {

+            for (j = 0; j < g; j++) {

+                temp = temp + pi[i*g+j] * 

+                    (exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i])) *

+                    (exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]));

+            }

+        }

+        for (i = 0; i < g; i++) {

+            for (j = 0; j < g; j++) {

+                zxy[(j*g+i)*n+k] = zxy[(j*g+i)*n+k] + pi[i*g+j] * 

+                    (exp(0-0.5*(x[k]-mu[i])*(x[k]-mu[i])/sigma[i])/sqrt(2*PI*sigma[i])) *

+                    (exp(0-0.5*(y[k]-nu[j])*(y[k]-nu[j])/tau[j])/sqrt(2*PI*tau[j]) ) / temp;

+            }

+        }

+    }

+    

+    Rcpp::List rtn = Rcpp::List::create(x, y, zxy, n, pi, mu, 

+                                        sigma, nu, tau, g);

+    

+    return rtn;

+}