void cut_sub(double **X, int n, int p, int G, int min_n, double lambda,
double *prob, double **Mu, double **LTSigma){
int i, index_center, size_nb, *index_prob;
int tmp_G = G - 1, tmp_min_n;
double new_pi[1] = {1.0}, **new_Mu, **new_LTSigma, **new_X;
double tmp_center;
/* Get the seed state from R. */
GetRNGstate();
/* Use inverse CDF to sample a new center according to the given prob. */
for(i = 1; i < n; i++) prob[i] = prob[i] + prob[i - 1];
tmp_center = runif(0, prob[n - 1]);
if(tmp_center <= prob[0]){
index_center = 0;
} else{
for(index_center = 1; index_center < n; index_center++){
if(tmp_center > prob[index_center - 1] &&
tmp_center <= prob[index_center]) break;
}
}
/* Based on the new center to estimate the new ltsigma. */
new_Mu = allocate_double_array(1);
new_LTSigma = allocate_double_array(1);
new_Mu[0] = Mu[tmp_G];
new_LTSigma[0] = LTSigma[tmp_G];
for(i = 0; i < p; i++) new_Mu[0][i] = X[index_center][i];
est_ltsigma_mle_given_mu(X, n, p, new_Mu[0], new_LTSigma[0]);
/* Compute prob based on the new center and ltsigma, and according
to the prob to find the neighbors with size min.n + rpois(1, lambda). */
for(i = 0; i < n; i++){
prob[i] = mixllhd(p, 1, X[i], new_pi, new_Mu, new_LTSigma);
}
index_prob = (int *) orderDouble(prob, n); /* This is an increasing order. */
size_nb = min_n + (int) rpois(lambda);
/* Based on the neighbors to estimate Mu and LTSigma. */
new_X = allocate_double_array(size_nb);
tmp_min_n = n - size_nb;
for(i = 0; i < size_nb; i++) new_X[i] = X[index_prob[tmp_min_n + i]];
meandispersion_MLE(new_X, size_nb, p, new_Mu[0], new_LTSigma[0]);
/* Release memory and set new seed state to R. */
PutRNGstate();
free(new_X);
free(new_Mu);
free(new_LTSigma);
FREE_VECTOR(index_prob);
} /* End of cut_sub(). */
//------------------------------------------------------------------
simpleExport int xvalues(double (*start_val_f)(double x),
int gSize,
double xMax,
double xMin,
double* out_p)
{
doubleArray valArray, xArray;
allocate_double_array(&valArray, gSize);
allocate_double_array(&xArray, gSize);
init_grid(&valArray, &xArray, (*start_val_f), gSize, xMax, xMin);
copy_result(&xArray, gSize, out_p);
return 7;
}
//------------------------------------------------------------------
simpleExport int cahnhilliard(double (*start_val_f)(double x),
int gSize,
double xMax,
double xMin,
double dt,
double TMAX,
double* out_p)
{
int i;
double dx;
doubleArray valArray, xArray, dArray, cubeArray, lptermArray, sumArray;
allocate_double_array(&valArray, gSize);
allocate_double_array(&xArray, gSize);
allocate_double_array(&dArray, gSize);
allocate_double_array(&cubeArray, gSize);
allocate_double_array(&lptermArray, gSize);
allocate_double_array(&sumArray, gSize);
init_grid(&valArray, &xArray, (*start_val_f), gSize, xMax, xMin);
dx = calc_dx(&xArray);
do_cahn_hilliard(&valArray,
&dArray,
&cubeArray,
&lptermArray,
&sumArray,
TMAX,
dt,
dx);
copy_result(&valArray, gSize, out_p);
return 7;
}
//------------------------------------------------------------------
simpleExport int diffusion(double (*start_val_f)(double x),
int gSize,
double xMax,
double xMin,
double dt,
double TMAX,
double* out_p)
{
int i;
double dx;
doubleArray valArray, xArray, dArray;
allocate_double_array(&valArray, gSize);
allocate_double_array(&xArray, gSize);
allocate_double_array(&dArray, gSize);
init_grid(&valArray, &xArray, (*start_val_f), gSize, xMax, xMin);
dx = calc_dx(&xArray);
do_diffusion(&valArray, &dArray, TMAX, dt, dx);
copy_result(&valArray, gSize, out_p);
return 7;
}
//------------------------------------------------------------------
simpleExport int phasefieldcrystal(double (*start_val_f)(double x),
int gSize,
double xMax,
double xMin,
double dt,
double TMAX,
double epsilon,
double* out_p)
{
int i;
double dx;
doubleArray valArray, xArray, dArray, cubeArray, lapOneArray, lapTwoArray, sumArray;
allocate_double_array(&valArray, gSize);
allocate_double_array(&xArray, gSize);
allocate_double_array(&dArray, gSize);
allocate_double_array(&cubeArray, gSize);
allocate_double_array(&lapOneArray, gSize);
allocate_double_array(&lapTwoArray, gSize);
allocate_double_array(&sumArray, gSize);
init_grid(&valArray, &xArray, (*start_val_f), gSize, xMax, xMin);
dx = calc_dx(&xArray);
do_phase_field_crystal(&valArray,
&dArray,
&cubeArray,
&lapOneArray,
&lapTwoArray,
&sumArray,
epsilon,
TMAX,
dt,
dx);
copy_result(&valArray, gSize, out_p);
return 7;
}
/* This function calls emcluster() in "src/emcluster.c" and is called by
emcluster() using .Call() in "R/fcn_emcluster.r".
Input:
R_x: SEXP[R_n * R_p], data matrix of R_n*R_p.
R_n: SEXP[1], number of observations.
R_p: SEXP[1], number of dimersions.
R_nclass: SEXP[1], number of classes. # k
R_p_LTSigma: SEXP[1], dimersion of LTSigma, p * (p + 1) / 2.
R_pi: SEXP[R_nclass], proportions of classes.
R_Mu: SEXP[R_nclass, R_p], means of MVNs.
R_LTSigma: SEXP[R_nclass, R_p * (R_p + 1) / 2], lower triangular sigma
matrices.
R_em_iter: SEXP[1], max iterations for emclust(), 1000 by default.
R_em_eps: SEXP[1], tolerance for emclust(), 1e-4 by default.
Output:
ret: a list contains
pi: SEXP[R_nclass], proportions of classes.
Mu: SEXP[R_nclass, R_p], means of MVNs.
LTSigma: SEXP[R_nclass, R_p * (R_p + 1) / 2], lower triangular sigma
matrices.
llhdval: SEXP[1], log likelihood value.
*/
SEXP R_emcluster(SEXP R_x, SEXP R_n, SEXP R_p, SEXP R_nclass, SEXP R_p_LTSigma,
SEXP R_pi, SEXP R_Mu, SEXP R_LTSigma, SEXP R_em_iter, SEXP R_em_eps){
/* Declare variables for calling C. */
double **C_x, *C_pi, **C_Mu, **C_LTSigma, *C_llhdval, *C_em_eps;
int *C_n, *C_p, *C_nclass, *C_p_LTSigma, *C_em_iter;
/* Declare variables for R's returning. */
SEXP pi, Mu, LTSigma, llhdval, ret, ret_names;
/* Declare variables for processing. */
double *tmp_1, *tmp_2;
int i, j, tl;
char *names[4] = {"pi", "Mu", "LTSigma", "llhdval"};
/* Set initial values. */
C_n = INTEGER(R_n);
C_p = INTEGER(R_p);
C_nclass = INTEGER(R_nclass);
C_p_LTSigma = INTEGER(R_p_LTSigma);
/* Allocate and protate storages. */
PROTECT(pi = allocVector(REALSXP, *C_nclass));
PROTECT(Mu = allocVector(REALSXP, *C_nclass * *C_p));
PROTECT(LTSigma = allocVector(REALSXP, *C_nclass * *C_p_LTSigma));
PROTECT(llhdval = allocVector(REALSXP, 1));
PROTECT(ret = allocVector(VECSXP, 4));
PROTECT(ret_names = allocVector(STRSXP, 4));
i = 0;
SET_VECTOR_ELT(ret, i++, pi);
SET_VECTOR_ELT(ret, i++, Mu);
SET_VECTOR_ELT(ret, i++, LTSigma);
SET_VECTOR_ELT(ret, i++, llhdval);
for(i = 0; i < 4; i++){
SET_STRING_ELT(ret_names, i, mkChar(names[i]));
}
setAttrib(ret, R_NamesSymbol, ret_names);
/* Assign data. */
C_x = allocate_double_array(*C_n);
C_Mu = allocate_double_array(*C_nclass);
C_LTSigma = allocate_double_array(*C_nclass);
tmp_1 = REAL(R_x);
for(i = 0; i < *C_n; i++){
C_x[i] = tmp_1;
tmp_1 += *C_p;
}
tmp_1 = REAL(Mu);
tmp_2 = REAL(LTSigma);
for(i = 0; i < *C_nclass; i++){
C_Mu[i] = tmp_1;
C_LTSigma[i] = tmp_2;
tmp_1 += *C_p;
tmp_2 += *C_p_LTSigma;
}
C_pi = REAL(pi);
C_llhdval = REAL(llhdval);
C_em_iter = INTEGER(R_em_iter);
C_em_eps = REAL(R_em_eps);
/* Copy R objects to input oebjects for C. */
tmp_1 = REAL(R_pi);
for(i = 0; i < *C_nclass; i++){
C_pi[i] = *(tmp_1 + i);
}
tl = 0;
tmp_1 = REAL(R_Mu);
for(i = 0; i < *C_nclass; i++){
for(j = 0; j < *C_p; j++){
C_Mu[i][j] = *(tmp_1 + tl++);
}
}
tl = 0;
tmp_1 = REAL(R_LTSigma);
for(i = 0; i < *C_nclass; i++){
for(j = 0; j < *C_p_LTSigma; j++){
C_LTSigma[i][j] = *(tmp_1 + tl++);
}
}
/* Compute. */
emcluster(*C_n, *C_p, *C_nclass, C_pi, C_x, C_Mu, C_LTSigma,
*C_em_iter, *C_em_eps, C_llhdval);
/* Free memory and release protectation. */
free(C_x);
free(C_Mu);
free(C_LTSigma);
UNPROTECT(6);
return(ret);
} /* End of R_emcluster(). */
/* This function calls mstep() in "src/emcluster.c" and is called by
m.step() using .Call() in "R/fcn_m_step.r".
Input:
R_x: SEXP[R_n * R_p], data matrix of R_n*R_p.
R_n: SEXP[1], number of observations.
R_p: SEXP[1], number of dimersions.
R_nclass: SEXP[1], number of classes. # k
R_Gamma: SEXP[R_n, R_p], posterios matrix of R_n*R_p.
Output:
ret: a list contains
pi: SEXP[R_nclass], proportions of classes.
Mu: SEXP[R_nclass, R_p], means of MVNs.
LTSigma: SEXP[R_nclass, R_p * (R_p + 1) / 2], lower triangular sigma
matrices.
*/
SEXP R_mstep(SEXP R_x, SEXP R_n, SEXP R_p, SEXP R_nclass, SEXP R_Gamma){
/* Declare variables for calling C. */
double **C_Gamma, **C_x, *C_pi, **C_Mu, **C_LTSigma;
int *C_n, *C_p, *C_nclass;
/* Declare variables for R's returning. */
SEXP pi, Mu, LTSigma, ret, ret_names;
/* Declare variables for processing. */
double *tmp_1, *tmp_2;
int i, p_LTSigma;
char *names[3] = {"pi", "Mu", "LTSigma"};
/* Set initial values. */
C_n = INTEGER(R_n);
C_p = INTEGER(R_p);
C_nclass = INTEGER(R_nclass);
p_LTSigma = *C_p * (*C_p + 1) / 2;
/* Allocate and protate storages. */
PROTECT(pi = allocVector(REALSXP, *C_nclass));
PROTECT(Mu = allocVector(REALSXP, *C_nclass * *C_p));
PROTECT(LTSigma = allocVector(REALSXP, *C_nclass * p_LTSigma));
PROTECT(ret = allocVector(VECSXP, 3));
PROTECT(ret_names = allocVector(STRSXP, 3));
i = 0;
SET_VECTOR_ELT(ret, i++, pi);
SET_VECTOR_ELT(ret, i++, Mu);
SET_VECTOR_ELT(ret, i++, LTSigma);
for(i = 0; i < 3; i++){
SET_STRING_ELT(ret_names, i, mkChar(names[i]));
}
setAttrib(ret, R_NamesSymbol, ret_names);
/* Assign data. */
C_Gamma = allocate_double_array(*C_n);
C_x = allocate_double_array(*C_n);
C_Mu = allocate_double_array(*C_nclass);
C_LTSigma = allocate_double_array(*C_nclass);
tmp_1 = REAL(R_Gamma);
tmp_2 = REAL(R_x);
for(i = 0; i < *C_n; i++){
C_Gamma[i] = tmp_1;
C_x[i] = tmp_2;
tmp_1 += *C_nclass;
tmp_2 += *C_p;
}
tmp_1 = REAL(Mu);
tmp_2 = REAL(LTSigma);
for(i = 0; i < *C_nclass; i++){
C_Mu[i] = tmp_1;
C_LTSigma[i] = tmp_2;
tmp_1 += *C_p;
tmp_2 += p_LTSigma;
}
C_pi = REAL(pi);
/* Compute. */
mstep(C_x, *C_n, *C_p, *C_nclass, C_pi, C_Mu, C_LTSigma, C_Gamma);
/* Free memory and release protectation. */
free(C_Gamma);
free(C_x);
free(C_Mu);
free(C_LTSigma);
UNPROTECT(5);
return(ret);
} /* End of R_mstep(). */
/* This function calls estep() in "src/emcluster.c" and is called by
e.step() using .Call() in "R/fcn_e_step.r".
Input:
R_x: SEXP[R_n * R_p], data matrix of R_n*R_p.
R_n: SEXP[1], number of observations.
R_p: SEXP[1], number of dimersions.
R_nclass: SEXP[1], number of classes. # k
R_p_LTSigma: SEXP[1], dimersion of LTSigma, p * (p + 1) / 2.
R_pi: SEXP[R_nclass], proportions of classes.
R_Mu: SEXP[R_nclass, R_p], means of MVNs.
R_LTSigma: SEXP[R_nclass, R_p * (R_p + 1) / 2], lower triangular sigma
matrices.
R_norm: SEXP[1], normalized.
Output:
ret: a list contains
Gamma: SEXP[R_n, R_p], posterios matrix of R_n*R_p.
*/
SEXP R_estep(SEXP R_x, SEXP R_n, SEXP R_p, SEXP R_nclass, SEXP R_p_LTSigma,
SEXP R_pi, SEXP R_Mu, SEXP R_LTSigma, SEXP R_norm){
/* Declare variables for calling C. */
double **C_Gamma, **C_x, *C_pi, **C_Mu, **C_LTSigma;
int *C_n, *C_p, *C_nclass, *C_p_LTSigma, *C_norm;
/* Declare variables for R's returning. */
SEXP Gamma, ret, ret_names;
/* Declare variables for processing. */
double *tmp_1, *tmp_2;
int i;
char *names[1] = {"Gamma"};
/* Set initial values. */
C_n = INTEGER(R_n);
C_p = INTEGER(R_p);
C_nclass = INTEGER(R_nclass);
C_p_LTSigma = INTEGER(R_p_LTSigma);
/* Allocate and protate storages. */
PROTECT(Gamma = allocVector(REALSXP, *C_n * *C_nclass));
PROTECT(ret = allocVector(VECSXP, 1));
PROTECT(ret_names = allocVector(STRSXP, 1));
SET_VECTOR_ELT(ret, 0, Gamma);
SET_STRING_ELT(ret_names, 0, mkChar(names[0]));
setAttrib(ret, R_NamesSymbol, ret_names);
/* Assign data. */
C_Gamma = allocate_double_array(*C_n);
C_x = allocate_double_array(*C_n);
C_Mu = allocate_double_array(*C_nclass);
C_LTSigma = allocate_double_array(*C_nclass);
tmp_1 = REAL(Gamma);
tmp_2 = REAL(R_x);
for(i = 0; i < *C_n; i++){
C_Gamma[i] = tmp_1;
C_x[i] = tmp_2;
tmp_1 += *C_nclass;
tmp_2 += *C_p;
}
tmp_1 = REAL(R_Mu);
tmp_2 = REAL(R_LTSigma);
for(i = 0; i < *C_nclass; i++){
C_Mu[i] = tmp_1;
C_LTSigma[i] = tmp_2;
tmp_1 += *C_p;
tmp_2 += *C_p_LTSigma;
}
C_pi = REAL(R_pi);
C_norm = INTEGER(R_norm);
/* Compute. */
if(*C_norm == 1){
estep(*C_n, *C_p, *C_nclass, C_x, C_Gamma, C_pi, C_Mu, C_LTSigma);
} else{
estep_unnorm_dlmvn(*C_n, *C_p, *C_nclass, C_x, C_Gamma, C_pi, C_Mu,
C_LTSigma);
}
/* Free memory and release protectation. */
free(C_Gamma);
free(C_x);
free(C_Mu);
free(C_LTSigma);
UNPROTECT(3);
return(ret);
} /* End of R_estep(). */
/* This function calls M_emgroup() in "src/M_emgroup.c" and is called by
emgroup() using .Call() in "R/fcn_emgroup.r".
Input:
R_x: SEXP[R_n * R_p], data matrix of R_n*R_p.
R_n: SEXP[1], number of observations.
R_p: SEXP[1], number of dimersions.
R_nclass: SEXP[1], number of classes.
R_alpha: SEXP[1], 0.99 by default.
R_em_iter: SEXP[1], max iterations for emclust(), 1000 by default.
R_em_eps: SEXP[1], tolerance for emclust(), 1e-4 by default.
Output:
ret: a list contains
pi: SEXP[R_nclass], proportions of classes.
Mu: SEXP[R_nclass, R_p], means of MVNs.
LTSigma: SEXP[R_nclass, R_p * (R_p + 1) / 2], lower triangular sigma
matrices.
llhdval: SEXP[1], log likelihood value.
nc: SEXP[R_nclass], number of observations in each class.
class: SEXP[R_n], class id's for all observations
starting from 0 to (R_nclass - 1).
flag: SEXP[1], a returned value from M_emgroup() in "src/M_emgroup.c".
*/
SEXP R_M_emgroup(SEXP R_x, SEXP R_n, SEXP R_p, SEXP R_nclass,
SEXP R_alpha, SEXP R_em_iter, SEXP R_em_eps){
/* Declare variables for calling C. */
double **C_x, *C_pi, **C_Mu, **C_LTSigma, *C_llhdval, *C_alpha, *C_em_eps;
int *C_n, *C_p, *C_nclass, *C_nc, *C_class, *C_flag, *C_em_iter;
/* Declare variables for R's returning. */
SEXP pi, Mu, LTSigma, llhdval, nc, class, flag,
ret, ret_names;
/* Declare variables for processing. */
double *tmp_1, *tmp_2;
int i, p_LTSigma;
char *names[7] = {"pi", "Mu", "LTSigma", "llhdval", "nc", "class", "flag"};
/* Set initial values. */
C_n = INTEGER(R_n);
C_p = INTEGER(R_p);
C_nclass = INTEGER(R_nclass);
p_LTSigma = *C_p * (*C_p + 1) / 2;
/* Allocate and protate storages. */
PROTECT(pi = allocVector(REALSXP, *C_nclass));
PROTECT(Mu = allocVector(REALSXP, *C_nclass * *C_p));
PROTECT(LTSigma = allocVector(REALSXP, *C_nclass * p_LTSigma));
PROTECT(llhdval = allocVector(REALSXP, 1));
PROTECT(nc = allocVector(INTSXP, *C_nclass));
PROTECT(class = allocVector(INTSXP, *C_n));
PROTECT(flag = allocVector(INTSXP, 1));
PROTECT(ret = allocVector(VECSXP, 7));
PROTECT(ret_names = allocVector(STRSXP, 7));
i = 0;
SET_VECTOR_ELT(ret, i++, pi);
SET_VECTOR_ELT(ret, i++, Mu);
SET_VECTOR_ELT(ret, i++, LTSigma);
SET_VECTOR_ELT(ret, i++, llhdval);
SET_VECTOR_ELT(ret, i++, nc);
SET_VECTOR_ELT(ret, i++, class);
SET_VECTOR_ELT(ret, i++, flag);
for(i = 0; i < 7; i++){
SET_STRING_ELT(ret_names, i, mkChar(names[i]));
}
setAttrib(ret, R_NamesSymbol, ret_names);
/* Assign data. */
C_x = allocate_double_array(*C_n);
C_Mu = allocate_double_array(*C_nclass);
C_LTSigma = allocate_double_array(*C_nclass);
tmp_1 = REAL(R_x);
for(i = 0; i < *C_n; i++){
C_x[i] = tmp_1;
tmp_1 += *C_p;
}
tmp_1 = REAL(Mu);
tmp_2 = REAL(LTSigma);
for(i = 0; i < *C_nclass; i++){
C_Mu[i] = tmp_1;
C_LTSigma[i] = tmp_2;
tmp_1 += *C_p;
tmp_2 += p_LTSigma;
}
C_pi = REAL(pi);
C_llhdval = REAL(llhdval);
C_nc = INTEGER(nc);
C_class = INTEGER(class);
C_flag = INTEGER(flag);
C_alpha = REAL(R_alpha);
C_em_iter = INTEGER(R_em_iter);
C_em_eps = REAL(R_em_eps);
/* Compute. */
*C_flag = M_emgroup(C_x, *C_n, *C_p, *C_nclass, C_pi, C_Mu, C_LTSigma,
C_llhdval, C_nc, C_class,
*C_alpha, *C_em_iter, *C_em_eps);
/* Free memory and release protectation. */
free(C_x);
free(C_Mu);
free(C_LTSigma);
UNPROTECT(9);
return(ret);
} /* End of R_emgroup(). */