Example #1
0
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;
}
Example #6
0
/* 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(). */
Example #7
0
/* 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(). */
Example #8
0
/* 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(). */
Example #9
0
/* 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(). */