SEXP R_THD_write_dset(SEXP Sfname, SEXP Sdset, SEXP Opts)
{
SEXP Rdset, brik, head, names, opt, node_list;
int i=0, ip=0, sb, cnt=0, scale = 1, overwrite=0, addFDR=0,
kparts=2, *iv=NULL;
char *fname = NULL, *head_str, *stmp=NULL, *hist=NULL;
NI_group *ngr=NULL;
NI_element *nel=NULL;
char *listels[3] = {"head","brk","index_list"}; /* the brk is on purpose
for backward compatibility */
double *dv=NULL;
float *fv=NULL;
THD_3dim_dataset *dset = NULL;
int debug=0;
if (!debug) debug = get_odebug();
/* get the options list, maybe */
PROTECT(Opts = AS_LIST(Opts));
if ((opt = getListElement(Opts,"debug")) != R_NilValue) {
debug = (int)INTEGER_VALUE(opt);
if (debug>2) set_odebug(debug);
if (debug > 1) INFO_message("Debug is %d\n", debug);
}
/* get the filename */
PROTECT(Sfname = AS_CHARACTER(Sfname));
fname = R_alloc(strlen(CHAR(STRING_ELT(Sfname,0)))+1, sizeof(char));
strcpy(fname, CHAR(STRING_ELT(Sfname,0)));
if (debug >1) INFO_message("Output filename %s\n"
, fname);
/* get the dset structure elements */
PROTECT(Rdset = AS_LIST(Sdset));
if ((head = AS_CHARACTER(getListElement(Rdset,"head"))) == R_NilValue) {
ERROR_message("No header found");
UNPROTECT(3);
return(R_NilValue);
}
if (debug > 1) INFO_message("First head element %s\n"
, CHAR(STRING_ELT(head,0)));
if ((brik = AS_NUMERIC(getListElement(Rdset,"brk"))) == R_NilValue) {
ERROR_message("No brick found");
UNPROTECT(3);
return(R_NilValue);
}
dv = NUMERIC_POINTER(brik);
if (debug > 1) INFO_message("First brik value %f\n"
, dv[0]);
ngr = NI_new_group_element();
NI_rename_group(ngr, "AFNI_dataset" );
NI_set_attribute(ngr,"AFNI_prefix", fname);
if ((opt = getListElement(Opts,"idcode")) != R_NilValue) {
opt = AS_CHARACTER(opt);
stmp = (char *)(CHAR(STRING_ELT(opt,0)));
if (stmp && !strcmp(stmp,"SET_AT_WRITE_FILENAME")) {
stmp = UNIQ_hashcode(fname);
NI_set_attribute(ngr, "AFNI_idcode", stmp);
free(stmp);
} else if (stmp && !strcmp(stmp,"SET_AT_WRITE_RANDOM")) {
stmp = UNIQ_idcode() ;
NI_set_attribute(ngr, "AFNI_idcode", stmp);
free(stmp);
} else if (stmp) {
NI_set_attribute(ngr, "AFNI_idcode",
(char *)(CHAR(STRING_ELT(opt,0))));
}
}
if ((opt = getListElement(Opts,"scale")) != R_NilValue) {
scale = (int)INTEGER_VALUE(opt);
if (debug > 1) INFO_message("Scale is %d\n", scale);
}
if ((opt = getListElement(Opts,"overwrite")) != R_NilValue) {
overwrite = (int)INTEGER_VALUE(opt);
if (debug > 1) INFO_message("overwrite is %d\n", overwrite);
THD_force_ok_overwrite(overwrite) ;
if (overwrite) THD_set_quiet_overwrite(1);
}
if ((opt = getListElement(Opts,"addFDR")) != R_NilValue) {
addFDR = (int)INTEGER_VALUE(opt);
if (debug > 1) INFO_message("addFDR is %d\n", addFDR);
}
PROTECT(opt = getListElement(Opts,"hist"));
if ( opt != R_NilValue) {
opt = AS_CHARACTER(opt);
hist = R_alloc(strlen(CHAR(STRING_ELT(opt,0)))+1, sizeof(char));
strcpy(hist, CHAR(STRING_ELT(opt,0)));
if (debug > 1) INFO_message("hist is %s\n", hist);
}
UNPROTECT(1);
for (ip=0,i=0; i<length(head); ++i) {
head_str = (char *)CHAR(STRING_ELT(head,i));
if (debug > 1) {
INFO_message("Adding %s\n", head_str);
}
nel = NI_read_element_fromstring(head_str);
if (!nel->vec) {
ERROR_message("Empty attribute vector for\n%s\n"
"This is not expected.\n",
head_str);
UNPROTECT(3);
return(R_NilValue);
}
NI_add_to_group(ngr,nel);
}
if (debug > 1) INFO_message("Creating dset header\n");
if (!(dset = THD_niml_to_dataset(ngr, 1))) {
ERROR_message("Failed to create header");
UNPROTECT(3);
return(R_NilValue);
}
if (debug > 2) {
INFO_message("Have header of %d, %d, %d, %d, scale=%d\n",
DSET_NX(dset), DSET_NY(dset),
DSET_NZ(dset), DSET_NVALS(dset), scale);
}
for (i=0; i<DSET_NVALS(dset); ++i) {
if (debug > 2) {
INFO_message("Putting values in sub-brick %d, type %d\n",
i, DSET_BRICK_TYPE(dset,i));
}
if ( ( DSET_BRICK_TYPE(dset,i) == MRI_byte ||
DSET_BRICK_TYPE(dset,i) == MRI_short ) ) {
EDIT_substscale_brick(dset, i,
MRI_double, dv+i*DSET_NVOX(dset),
DSET_BRICK_TYPE(dset,i), scale ? -1.0:1.0);
} else if ( DSET_BRICK_TYPE(dset,i) == MRI_double ) {
EDIT_substitute_brick(dset, i,
MRI_double, dv+i*DSET_NVOX(dset));
} else if ( DSET_BRICK_TYPE(dset,i) == MRI_float ) {
float *ff=(float*)calloc(DSET_NVOX(dset), sizeof(float));
double *dvi=dv+i*DSET_NVOX(dset);
for (ip=0; ip<DSET_NVOX(dset); ++ip) {
ff[ip] = dvi[ip];
}
EDIT_substitute_brick(dset, i, MRI_float, ff);
}
}
/* THD_update_statistics( dset ) ; */
if (addFDR) {
DSET_BRICK_FDRCURVE_ALLKILL(dset) ;
DSET_BRICK_MDFCURVE_ALLKILL(dset) ; /* 22 Oct 2008 */
if( addFDR > 0 ){
int nFDRmask=0; /* in the future, perhaps allow for a mask */
byte *FDRmask=NULL; /* to be sent in also, for now, mask is exact */
/* 0 voxels . */
mri_fdr_setmask( (nFDRmask == DSET_NVOX(dset)) ? FDRmask : NULL ) ;
ip = THD_create_all_fdrcurves(dset) ;
if( ip > 0 ){
if (debug)
ININFO_message("created %d FDR curve%s in dataset header",
ip,(ip==1)?"\0":"s") ;
} else {
if (debug)
ININFO_message("failed to create FDR curves in dataset header") ;
}
}
}
/* Do we have an index_list? */
if ((node_list=AS_INTEGER(getListElement(Rdset,"index_list")))!=R_NilValue) {
iv = INTEGER_POINTER(node_list);
if (debug > 1) INFO_message("First node index value %d, total (%d)\n",
iv[0], length(node_list));
dset->dblk->nnodes = length(node_list);
dset->dblk->node_list = (int *)XtMalloc(dset->dblk->nnodes * sizeof(int));
memcpy(dset->dblk->node_list, iv, dset->dblk->nnodes*sizeof(int));
}
if (hist) {
tross_Append_History(dset, hist);
}
DSET_write(dset);
UNPROTECT(3);
return(R_NilValue);
}
SEXP R_THD_load_dset(SEXP Sfname, SEXP Opts)
{
SEXP Rdset, brik, head, names, opt, node_list=R_NilValue;
int i=0, ip=0, sb, cnt=0, *iv=NULL, kparts=2;
char *fname = NULL, *head_str;
NI_group *ngr=NULL;
NI_element *nel=NULL;
char *listels[3] = {"head","brk","index_list"}; /* the brk is on purpose
for backward compatibility */
double *dv=NULL;
float *fv=NULL;
THD_3dim_dataset *dset = NULL;
int debug=0;
if (!debug) debug = get_odebug();
/* get the options list, maybe */
PROTECT(Opts = AS_LIST(Opts));
if ((opt = getListElement(Opts,"debug")) != R_NilValue) {
debug = (int)INTEGER_VALUE(opt);
if (debug>2) set_odebug(debug);
if (debug>1) INFO_message("Debug is %d\n", debug);
}
/* get the filename */
PROTECT(Sfname = AS_CHARACTER(Sfname));
fname = R_alloc(strlen(CHAR(STRING_ELT(Sfname,0)))+1, sizeof(char));
strcpy(fname, CHAR(STRING_ELT(Sfname,0)));
/* open dset */
dset = THD_open_dataset(fname);
if (dset) {
if (debug > 1) INFO_message("Dset %s was loaded 2\n", fname);
} else {
ERROR_message("Dset %s could not be loaded\n", fname);
UNPROTECT(2);
return(R_NilValue);
}
/* form one long header string */
ngr = THD_nimlize_dsetatr(dset);
PROTECT(head = allocVector(STRSXP, ngr->part_num));
for (ip=0,i=0; i<ngr->part_num; ++i) {
switch( ngr->part_typ[i] ){
/*-- a sub-group ==> recursion! --*/
case NI_GROUP_TYPE:
break ;
case NI_ELEMENT_TYPE:
nel = (NI_element *)ngr->part[i] ;
head_str = NI_write_element_tostring(nel);
if (debug > 1) fprintf(stderr,"%s\n", head_str);
SET_STRING_ELT(head, ip, mkChar(head_str)); ++ip;
free(head_str);
break;
default:
break;
}
}
NI_free_element(ngr);
if (debug > 1) fprintf(stderr,"Forming data array of %d elements\n",
DSET_NVOX(dset)*DSET_NVALS(dset));
/* form one long array of data */
PROTECT(brik = NEW_NUMERIC(DSET_NVOX(dset)*DSET_NVALS(dset)));
dv = NUMERIC_POINTER(brik);
EDIT_floatize_dataset(dset);
for (cnt=0, sb=0; sb<DSET_NVALS(dset); ++sb) {
if (!(fv = (float *)DSET_BRICK_ARRAY(dset,sb))) {
ERROR_message("NULL brick array %d!\n", sb);
UNPROTECT(4);
return(R_NilValue);
}
if (debug > 1) fprintf(stderr,"Filling sb %d\n", sb);
for (i=0; i<DSET_NVOX(dset); ++i) {
dv[cnt++] = fv[i];
if (debug > 1) {
if (debug > 2 || i<10) {
fprintf(stderr,"%f\t", fv[i]);
}
}
}
if (debug == 2) fprintf(stderr,"...\n");
else if (debug > 2) fprintf(stderr,"\n");
}
/* how about an index list ? */
if (dset->dblk->nnodes && dset->dblk->node_list) {
if (debug > 1)
fprintf(stderr,"Copying %d node indices\n", dset->dblk->nnodes);
PROTECT(node_list = NEW_INTEGER(dset->dblk->nnodes));
iv = INTEGER_POINTER(node_list);
memcpy(iv, dset->dblk->node_list, dset->dblk->nnodes*sizeof(int));
kparts = 3;
} else {
kparts = 2;
if (debug > 1)
fprintf(stderr,"No node indices %d %p\n",
dset->dblk->nnodes, dset->dblk->node_list);
}
/* done with dset, dump it */
DSET_delete(dset);
/* form output list */
PROTECT(names = allocVector(STRSXP,kparts));
for (i=0; i<kparts; ++i) {
SET_STRING_ELT(names, i, mkChar(listels[i]));
}
PROTECT(Rdset = allocVector(VECSXP,kparts));
SET_VECTOR_ELT(Rdset, 0, head);
SET_VECTOR_ELT(Rdset, 1, brik);
if (node_list != R_NilValue) SET_VECTOR_ELT(Rdset, 2, node_list);
setAttrib(Rdset, R_NamesSymbol, names);
if (debug > 1) fprintf(stderr,"Unprotecting...\n");
if (kparts==3) UNPROTECT(7);
else UNPROTECT(6);
return(Rdset);
}
SEXP DEoptimC(SEXP lower, SEXP upper, SEXP fn, SEXP control, SEXP rho, SEXP fnMap)
{
int i, j, P=0;
if (!isFunction(fn))
error("fn is not a function!");
if (!isEnvironment(rho))
error("rho is not an environment!");
/*-----Initialization of annealing parameters-------------------------*/
/* value to reach */
double VTR = NUMERIC_VALUE(getListElement(control, "VTR"));
/* chooses DE-strategy */
int i_strategy = INTEGER_VALUE(getListElement(control, "strategy"));
/* Maximum number of generations */
int i_itermax = INTEGER_VALUE(getListElement(control, "itermax"));
/* Dimension of parameter vector */
int i_D = INTEGER_VALUE(getListElement(control, "npar"));
/* Number of population members */
int i_NP = INTEGER_VALUE(getListElement(control, "NP"));
/* When to start storing populations */
int i_storepopfrom = INTEGER_VALUE(getListElement(control, "storepopfrom"))-1;
/* How often to store populations */
int i_storepopfreq = INTEGER_VALUE(getListElement(control, "storepopfreq"));
/* User-defined inital population */
int i_specinitialpop = INTEGER_VALUE(getListElement(control, "specinitialpop"));
double *initialpopv = NUMERIC_POINTER(getListElement(control, "initialpop"));
/* stepsize */
double d_weight = NUMERIC_VALUE(getListElement(control, "F"));
/* crossover probability */
double d_cross = NUMERIC_VALUE(getListElement(control, "CR"));
/* Best of parent and child */
int i_bs_flag = NUMERIC_VALUE(getListElement(control, "bs"));
/* Print progress? */
int i_trace = NUMERIC_VALUE(getListElement(control, "trace"));
/* p to define the top 100p% best solutions */
double d_pPct = NUMERIC_VALUE(getListElement(control, "p"));
/* crossover adaptation (a positive constant between 0 and 1) */
double d_c = NUMERIC_VALUE(getListElement(control, "c"));
/* relative tolerance */
double d_reltol = NUMERIC_VALUE(getListElement(control, "reltol"));
/* relative tolerance steps */
int i_steptol = NUMERIC_VALUE(getListElement(control, "steptol"));
int i_nstorepop = ceil((i_itermax - i_storepopfrom) / i_storepopfreq);
/* Use S_alloc, since it initializes with zeros FIXME: these should be SEXP */
double *gd_storepop = (double *)S_alloc(i_NP,sizeof(double) * i_D * i_nstorepop);
/* External pointers to return to R */
SEXP sexp_bestmem, sexp_bestval, sexp_nfeval, sexp_iter,
out, sexp_pop, sexp_storepop, sexp_bestmemit, sexp_bestvalit;
PROTECT(sexp_bestmem = NEW_NUMERIC(i_D)); P++;
PROTECT(sexp_pop = allocMatrix(REALSXP, i_D, i_NP)); P++;
PROTECT(sexp_bestmemit = allocMatrix(REALSXP, i_itermax, i_D)); P++;
PROTECT(sexp_bestvalit = allocVector(REALSXP, i_itermax)); P++;
double *gt_bestP = REAL(sexp_bestmem);
double *gd_pop = REAL(sexp_pop);
double *gd_bestmemit = REAL(sexp_bestmemit);
double *gd_bestvalit = REAL(sexp_bestvalit);
/* ensure lower and upper are double */
if(TYPEOF(lower) != REALSXP) {PROTECT(lower = coerceVector(lower, REALSXP)); P++;}
if(TYPEOF(upper) != REALSXP) {PROTECT(upper = coerceVector(upper, REALSXP)); P++;}
double *d_lower = REAL(lower);
double *d_upper = REAL(upper);
double gt_bestC;
int gi_iter = 0;
long l_nfeval = 0;
/*---optimization--------------------------------------*/
devol(VTR, d_weight, d_cross, i_bs_flag, d_lower, d_upper, fn, rho, i_trace,
i_strategy, i_D, i_NP, i_itermax,
initialpopv, i_storepopfrom, i_storepopfreq,
i_specinitialpop,
gt_bestP, >_bestC,
gd_pop, gd_storepop, gd_bestmemit, gd_bestvalit,
&gi_iter, d_pPct, d_c, &l_nfeval,
d_reltol, i_steptol, fnMap);
/*---end optimization----------------------------------*/
j = i_nstorepop * i_NP * i_D;
PROTECT(sexp_storepop = NEW_NUMERIC(j)); P++;
for (i = 0; i < j; i++)
NUMERIC_POINTER(sexp_storepop)[i] = gd_storepop[i];
PROTECT(sexp_nfeval = ScalarInteger(l_nfeval)); P++;
PROTECT(sexp_iter = ScalarInteger(gi_iter)); P++;
PROTECT(sexp_bestval = ScalarReal(gt_bestC)); P++;
const char *out_names[] = {"bestmem", "bestval", "nfeval",
"iter", "bestmemit", "bestvalit", "pop", "storepop", ""};
PROTECT(out = mkNamed(VECSXP, out_names)); P++;
SET_VECTOR_ELT(out, 0, sexp_bestmem);
SET_VECTOR_ELT(out, 1, sexp_bestval);
SET_VECTOR_ELT(out, 2, sexp_nfeval);
SET_VECTOR_ELT(out, 3, sexp_iter);
SET_VECTOR_ELT(out, 4, sexp_bestmemit);
SET_VECTOR_ELT(out, 5, sexp_bestvalit);
SET_VECTOR_ELT(out, 6, sexp_pop);
SET_VECTOR_ELT(out, 7, sexp_storepop);
UNPROTECT(P);
return out;
}
SEXP magmaCholeskyFinal(SEXP A, SEXP n, SEXP NB, SEXP id, SEXP zeroTri, SEXP lowerTri)
{
magma_init();
// magma_print_devices();
double *h_R;
int In, INB, ID;
In = INTEGER_VALUE(n);
INB = INTEGER_VALUE(NB);
ID = INTEGER_VALUE(id);
double *PA = NUMERIC_POINTER(A);
int i,j;
magma_int_t N, n2, lda, status, info, max_size;
N=In;
lda = N;
n2 = lda*N;
/* for(i = 0; i < In; i++)
{
for(j = 0; j < In; j++)
{
printf("%.8f ", PA[i+j*In]);
}
printf("\n");
} */
if ( MAGMA_SUCCESS != magma_malloc_pinned( (void**) &h_R, (n2)*sizeof(double) )) {
fprintf( stderr, "!!!! magma_malloc_pinned failed for: %s\n", h_R );
magma_finalize();
exit(-1);
}
lapackf77_dlacpy( MagmaUpperLowerStr, &N, &N, PA, &lda, h_R, &lda );
N = In;
status = 0;
magma_setdevice(ID);
//printf("Modified by Vinay in one GPU\n");
//INB = magma_get_dpotrf_nb(N);
// INB = 224;
// printf("INB = %d\n", INB);
//ngpu = ndevices;
// printf("ngpu = %d\n", ngpu);
//max_size = INB*(1+N/(INB*ndevices))*INB*((N+INB-1)/INB);
// printf("max_size = %d\n", max_size);
//int imax_size = max_size;
//double *dA;
//magma_dmalloc_pinned((void**)&dA, In*In*sizeof(double));
//ldda = (1+N/(INB*ndevices))*INB;
// printf("ldda = %d\n", ldda);
//magma_dsetmatrix_1D_row_bcyclic(N, N, PA, N, dA, ldda, ngpu, INB);
//magma_dpotrf_mgpu(ngpu, MagmaLower, N, dA, ldda, &info);
int lTri;
lTri = INTEGER_VALUE(lowerTri);
if(lTri)
magma_dpotrf(MagmaLower, N, h_R, N, &info);
else
magma_dpotrf(MagmaUpper, N, h_R, N, &info);
if(info != 0)
{
printf("magma_dpotrf returned error %d: %s.\n", (int) info, magma_strerror(info));
}
lapackf77_dlacpy( MagmaUpperLowerStr, &N, &N, h_R, &lda, PA, &lda );
//magma_dgetmatrix_1D_row_bcyclic(N, N, dA, ldda, PA, N, ngpu, INB);
//for(dev = 0; dev < ndevices; dev++)
//{
//magma_setdevice(dev);
//cudaFree(dA[dev]);
//}
magma_free_pinned(h_R);
magma_finalize();
cublasShutdown();
/*
int IZeroTri;
IZeroTri = INTEGER_VALUE(zeroTri);
if(IZeroTri & lTri) {
for(i = 1; i < In; i++)
{
for(j=0; j< i; j++)
{
PA[i*In+j] = 0.0;
}
}
}
else if(IZeroTri)
for(i = 0; i < In; i++)
{
for(j=i+1; j < In; j++)
{
PA[i*In+j] = 0.0;
}
}*/
return(R_NilValue);
}
SEXP magmaCholeskyFinal_m(SEXP A, SEXP n, SEXP NB, SEXP zeroTri, SEXP ngpu, SEXP lowerTri)
{
magma_init();
int ndevices;
double *h_R;
ndevices = INTEGER_VALUE(ngpu);
int idevice;
for(idevice=0; idevice < ndevices; idevice++)
{
magma_setdevice(idevice);
if(CUBLAS_STATUS_SUCCESS != cublasInit())
{
printf("Error: gpu %d: cublasInit failed\n", idevice);
magma_finalize();
exit(-1);
}
}
// magma_print_devices();
int In, INB;
In = INTEGER_VALUE(n);
INB = INTEGER_VALUE(NB);
double *PA = NUMERIC_POINTER(A);
int i,j;
//magma_timestr_t start, end;
double gpu_time;
printf("Inside magma_dpotrf_m");
/*for(i = 0; i < 5; i++)
{
for(j = 0; j < 5; j++)
{
printf("%.8f ", PA[i+j*In]);
}
printf("\n");
} */
magma_int_t N, status, info, nGPU, n2, lda;
clock_t t1, t2;
N = In;
status = 0;
int nGPUs = ndevices;
lda = N;
n2 = lda*N;
if ( MAGMA_SUCCESS != magma_malloc_pinned( (void**) &h_R, (n2)*sizeof(double) )) {
fprintf( stderr, "!!!! magma_malloc_pinned failed for: %s\n", h_R );
magma_finalize();
exit(-1);
}
lapackf77_dlacpy( MagmaUpperLowerStr, &N, &N, PA, &lda, h_R, &lda );
//printf("Modified by Vinay in 2 GPU\n");
//INB = magma_get_dpotrf_nb(N);
// INB = 224;
// printf("INB = %d\n", INB);
//ngpu = ndevices;
// printf("ngpu = %d\n", ngpu);
//max_size = INB*(1+N/(INB*ndevices))*INB*((N+INB-1)/INB);
// printf("max_size = %d\n", max_size);
//int imax_size = max_size;
//double *dA;
//magma_dmalloc_pinned((void**)&dA, In*In*sizeof(double));
//ldda = (1+N/(INB*ndevices))*INB;
// printf("ldda = %d\n", ldda);
//magma_dsetmatrix_1D_row_bcyclic(N, N, PA, N, dA, ldda, ngpu, INB);
//magma_dpotrf_mgpu(ngpu, MagmaLower, N, dA, ldda, &info);
int lTri;
lTri = INTEGER_VALUE(lowerTri);
if(lTri){
t1 = clock();
magma_dpotrf_m(nGPUs, MagmaLower, N, h_R, N, &info);
t2 = clock ();
}
else{
t1 = clock();
magma_dpotrf_m(nGPUs, MagmaUpper, N, h_R, N, &info);
t2 = clock ();
}
gpu_time = (double) (t2-t1)/(CLOCKS_PER_SEC) ; // Magma time
printf (" magma_dpotrf_m time : %f sec. \n", gpu_time );
if(info != 0)
{
printf("magma_dpotrf returned error %d: %s.\n", (int) info, magma_strerror(info));
}
//magma_dgetmatrix_1D_row_bcyclic(N, N, dA, ldda, PA, N, ngpu, INB);
//for(dev = 0; dev < ndevices; dev++)
//{
//magma_setdevice(dev);
//cudaFree(dA[dev]);
//}
lapackf77_dlacpy( MagmaUpperLowerStr, &N, &N, h_R, &lda, PA, &lda );
magma_free_pinned(h_R);
magma_finalize();
cublasShutdown();
int IZeroTri;
IZeroTri = INTEGER_VALUE(zeroTri);
if(IZeroTri & lTri) {
for(i = 1; i < In; i++)
{
for(j=0; j< i; j++)
{
PA[i*In+j] = 0.0;
}
}
}
else if(IZeroTri){
for(i = 0; i < In; i++)
{
for(j=i+1; j < In; j++)
{
PA[i*In+j] = 0.0;
}
}
}
return(R_NilValue);
}
SEXP rph_phyloFit(SEXP msaP,
SEXP treeStrP,
SEXP substModP,
SEXP scaleOnlyP,
SEXP scaleSubtreeP,
SEXP nratesP,
SEXP alphaP,
SEXP rateConstantsP,
SEXP initModP,
SEXP initBackgdFromDataP,
SEXP initRandomP,
SEXP initParsimonyP,
SEXP clockP,
SEXP emP,
SEXP maxEmItsP,
SEXP precisionP,
SEXP gffP,
SEXP ninfSitesP,
SEXP quietP,
SEXP noOptP,
SEXP boundP,
SEXP logFileP,
SEXP selectionP) {
struct phyloFit_struct *pf;
int numProtect=0, i;
double *doubleP;
char *die_message=NULL;
SEXP rv=R_NilValue;
List *new_rate_consts = NULL;
List *new_rate_weights = NULL;
GetRNGstate(); //seed R's random number generator
pf = phyloFit_struct_new(1); //sets appropriate defaults for RPHAST mode
pf->msa = (MSA*)EXTPTR_PTR(msaP);
if (treeStrP != R_NilValue)
pf->tree = rph_tree_new(treeStrP);
pf->use_em = LOGICAL_VALUE(emP);
if (rateConstantsP != R_NilValue) {
PROTECT(rateConstantsP = AS_NUMERIC(rateConstantsP));
numProtect++;
doubleP = NUMERIC_POINTER(rateConstantsP);
new_rate_consts = lst_new_dbl(LENGTH(rateConstantsP));
for (i=0; i < LENGTH(rateConstantsP); i++)
lst_push_dbl(new_rate_consts, doubleP[i]);
// pf->use_em = 1;
}
if (initModP != R_NilValue) {
pf->input_mod = (TreeModel*)EXTPTR_PTR(initModP);
pf->subst_mod = pf->input_mod->subst_mod;
tm_register_protect(pf->input_mod);
if (new_rate_consts == NULL && pf->input_mod->rK != NULL && pf->input_mod->nratecats > 1) {
new_rate_consts = lst_new_dbl(pf->input_mod->nratecats);
for (i=0; i < pf->input_mod->nratecats; i++)
lst_push_dbl(new_rate_consts, pf->input_mod->rK[i]);
// pf-> = 1;
}
if (pf->input_mod->empirical_rates && pf->input_mod->freqK != NULL && pf->input_mod->nratecats > 1) {
new_rate_weights = lst_new_dbl(pf->input_mod->nratecats);
for (i=0; i < pf->input_mod->nratecats; i++)
lst_push_dbl(new_rate_weights, pf->input_mod->freqK[i]);
}
tm_reinit(pf->input_mod,
rph_get_subst_mod(substModP),
nratesP == R_NilValue ? pf->input_mod->nratecats : INTEGER_VALUE(nratesP),
NUMERIC_VALUE(alphaP),
new_rate_consts,
new_rate_weights);
} else {
if (nratesP != R_NilValue)
pf->nratecats = INTEGER_VALUE(nratesP);
if (alphaP != R_NilValue)
pf->alpha = NUMERIC_VALUE(alphaP);
if (rateConstantsP != R_NilValue) {
pf->rate_consts = new_rate_consts;
if (nratesP == R_NilValue)
pf->nratecats = lst_size(new_rate_consts);
else if (lst_size(new_rate_consts) != pf->nratecats)
die("length of new_rate_consts does not match nratecats\n");
}
}
pf->subst_mod = rph_get_subst_mod(substModP);
pf->estimate_scale_only = LOGICAL_VALUE(scaleOnlyP);
if (scaleSubtreeP != R_NilValue) {
pf->subtree_name = smalloc((1+strlen(CHARACTER_VALUE(scaleSubtreeP)))*sizeof(char));
strcpy(pf->subtree_name, CHARACTER_VALUE(scaleSubtreeP));
}
pf->random_init = LOGICAL_VALUE(initRandomP);
pf->init_backgd_from_data = LOGICAL_VALUE(initBackgdFromDataP);
pf->init_parsimony = LOGICAL_VALUE(initParsimonyP);
pf->assume_clock = LOGICAL_VALUE(clockP);
if (maxEmItsP != R_NilValue)
pf->max_em_its = INTEGER_VALUE(maxEmItsP);
pf->precision = get_precision(CHARACTER_VALUE(precisionP));
if (pf->precision == OPT_UNKNOWN_PREC) {
die_message = "invalid precision";
goto rph_phyloFit_end;
}
if (gffP != R_NilValue) {
pf->gff = (GFF_Set*)EXTPTR_PTR(gffP);
gff_register_protect(pf->gff);
}
if (ninfSitesP != R_NilValue)
pf->nsites_threshold = INTEGER_VALUE(ninfSitesP);
pf->quiet = LOGICAL_VALUE(quietP);
if (noOptP != R_NilValue) {
int len=LENGTH(noOptP), pos=0;
char *temp;
for (i=0; i < LENGTH(noOptP); i++)
len += strlen(CHARACTER_VALUE(STRING_ELT(noOptP, i)));
temp = smalloc(len*sizeof(char));
for (i=0; i < LENGTH(noOptP); i++) {
if (i != 0) temp[pos++] = ',';
sprintf(&temp[pos], "%s", CHARACTER_VALUE(STRING_ELT(noOptP, i)));
pos += strlen(CHARACTER_VALUE(STRING_ELT(noOptP, i)));
}
if (pos != len-1) die("ERROR parsing noOpt len=%i pos=%i\n", len, pos);
temp[pos] = '\0';
pf->nooptstr = str_new_charstr(temp);
}
if (boundP != R_NilValue) {
pf->bound_arg = lst_new_ptr(LENGTH(boundP));
for (i=0; i < LENGTH(boundP); i++) {
String *temp = str_new_charstr(CHARACTER_VALUE(STRING_ELT(boundP, i)));
lst_push_ptr(pf->bound_arg, temp);
}
}
if (logFileP != R_NilValue) {
if (IS_CHARACTER(logFileP))
pf->logf = phast_fopen(CHARACTER_VALUE(logFileP), "w+");
else if (IS_LOGICAL(logFileP) &&
LOGICAL_VALUE(logFileP)) {
pf->logf = stdout;
}
}
if (selectionP != R_NilValue) {
pf->use_selection = TRUE;
pf->selection = NUMERIC_VALUE(selectionP);
}
msa_register_protect(pf->msa);
run_phyloFit(pf);
rv = PROTECT(rph_listOfLists_to_SEXP(pf->results));
numProtect++;
rph_phyloFit_end:
if (pf->logf != NULL && pf->logf != stdout && pf->logf != stderr)
phast_fclose(pf->logf);
PutRNGstate();
if (die_message != NULL) die(die_message);
if (numProtect > 0)
UNPROTECT(numProtect);
return rv;
}
SEXP euler_model_simulator (SEXP func,
SEXP xstart, SEXP times, SEXP params,
SEXP deltat, SEXP method, SEXP zeronames,
SEXP tcovar, SEXP covar, SEXP args, SEXP gnsi)
{
int nprotect = 0;
pompfunmode mode = undef;
int nvars, npars, nreps, ntimes, nzeros, ncovars, covlen;
int nstep = 0;
double dt, dtt;
SEXP X;
SEXP ans, nm, fn, fcall = R_NilValue, rho = R_NilValue;
SEXP Snames, Pnames, Cnames;
SEXP cvec, tvec = R_NilValue;
SEXP xvec = R_NilValue, pvec = R_NilValue, dtvec = R_NilValue;
int *pidx = 0, *sidx = 0, *cidx = 0, *zidx = 0;
pomp_onestep_sim *ff = NULL;
int meth = INTEGER_VALUE(method);
// meth: 0 = Euler, 1 = one-step, 2 = fixed step
dtt = NUMERIC_VALUE(deltat);
if (dtt <= 0)
errorcall(R_NilValue,"'delta.t' should be a positive number");
{
int *dim;
dim = INTEGER(GET_DIM(xstart)); nvars = dim[0]; nreps = dim[1];
dim = INTEGER(GET_DIM(params)); npars = dim[0];
dim = INTEGER(GET_DIM(covar)); covlen = dim[0]; ncovars = dim[1];
ntimes = LENGTH(times);
}
PROTECT(Snames = GET_ROWNAMES(GET_DIMNAMES(xstart))); nprotect++;
PROTECT(Pnames = GET_ROWNAMES(GET_DIMNAMES(params))); nprotect++;
PROTECT(Cnames = GET_COLNAMES(GET_DIMNAMES(covar))); nprotect++;
// set up the covariate table
struct lookup_table covariate_table = {covlen, ncovars, 0, REAL(tcovar), REAL(covar)};
// vector for interpolated covariates
PROTECT(cvec = NEW_NUMERIC(ncovars)); nprotect++;
SET_NAMES(cvec,Cnames);
// indices of accumulator variables
nzeros = LENGTH(zeronames);
zidx = INTEGER(PROTECT(matchnames(Snames,zeronames,"state variables"))); nprotect++;
// extract user function
PROTECT(fn = pomp_fun_handler(func,gnsi,&mode)); nprotect++;
// set up
switch (mode) {
case Rfun: // R function
PROTECT(dtvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(tvec = NEW_NUMERIC(1)); nprotect++;
PROTECT(xvec = NEW_NUMERIC(nvars)); nprotect++;
PROTECT(pvec = NEW_NUMERIC(npars)); nprotect++;
SET_NAMES(xvec,Snames);
SET_NAMES(pvec,Pnames);
// set up the function call
PROTECT(fcall = LCONS(cvec,args)); nprotect++;
SET_TAG(fcall,install("covars"));
PROTECT(fcall = LCONS(dtvec,fcall)); nprotect++;
SET_TAG(fcall,install("delta.t"));
PROTECT(fcall = LCONS(pvec,fcall)); nprotect++;
SET_TAG(fcall,install("params"));
PROTECT(fcall = LCONS(tvec,fcall)); nprotect++;
SET_TAG(fcall,install("t"));
PROTECT(fcall = LCONS(xvec,fcall)); nprotect++;
SET_TAG(fcall,install("x"));
PROTECT(fcall = LCONS(fn,fcall)); nprotect++;
// get function's environment
PROTECT(rho = (CLOENV(fn))); nprotect++;
break;
case native: // native code
// construct state, parameter, covariate indices
sidx = INTEGER(PROTECT(matchnames(Snames,GET_SLOT(func,install("statenames")),"state variables"))); nprotect++;
pidx = INTEGER(PROTECT(matchnames(Pnames,GET_SLOT(func,install("paramnames")),"parameters"))); nprotect++;
cidx = INTEGER(PROTECT(matchnames(Cnames,GET_SLOT(func,install("covarnames")),"covariates"))); nprotect++;
*((void **) (&ff)) = R_ExternalPtrAddr(fn);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
// create array to hold results
{
int dim[3] = {nvars, nreps, ntimes};
PROTECT(X = makearray(3,dim)); nprotect++;
setrownames(X,Snames,3);
}
// copy the start values into the result array
memcpy(REAL(X),REAL(xstart),nvars*nreps*sizeof(double));
if (mode==1) {
set_pomp_userdata(args);
GetRNGstate();
}
// now do computations
{
int first = 1;
int use_names = 0;
int *posn = 0;
double *time = REAL(times);
double *xs = REAL(X);
double *xt = REAL(X)+nvars*nreps;
double *cp = REAL(cvec);
double *ps = REAL(params);
double t = time[0];
double *pm, *xm;
int i, j, k, step;
for (step = 1; step < ntimes; step++, xs = xt, xt += nvars*nreps) {
R_CheckUserInterrupt();
if (t > time[step]) {
errorcall(R_NilValue,"'times' is not an increasing sequence");
}
memcpy(xt,xs,nreps*nvars*sizeof(double));
// set accumulator variables to zero
for (j = 0; j < nreps; j++)
for (i = 0; i < nzeros; i++)
xt[zidx[i]+nvars*j] = 0.0;
switch (meth) {
case 0: // Euler method
dt = dtt;
nstep = num_euler_steps(t,time[step],&dt);
break;
case 1: // one step
dt = time[step]-t;
nstep = (dt > 0) ? 1 : 0;
break;
case 2: // fixed step
dt = dtt;
nstep = num_map_steps(t,time[step],dt);
break;
default:
errorcall(R_NilValue,"unrecognized 'method'"); // # nocov
break;
}
for (k = 0; k < nstep; k++) { // loop over Euler steps
// interpolate the covar functions for the covariates
table_lookup(&covariate_table,t,cp);
for (j = 0, pm = ps, xm = xt; j < nreps; j++, pm += npars, xm += nvars) { // loop over replicates
switch (mode) {
case Rfun: // R function
{
double *xp = REAL(xvec);
double *pp = REAL(pvec);
double *tp = REAL(tvec);
double *dtp = REAL(dtvec);
double *ap;
*tp = t;
*dtp = dt;
memcpy(xp,xm,nvars*sizeof(double));
memcpy(pp,pm,npars*sizeof(double));
if (first) {
PROTECT(ans = eval(fcall,rho)); nprotect++; // evaluate the call
if (LENGTH(ans) != nvars) {
errorcall(R_NilValue,"user 'step.fun' returns a vector of %d state variables but %d are expected: compare initial conditions?",
LENGTH(ans),nvars);
}
PROTECT(nm = GET_NAMES(ans)); nprotect++;
use_names = !isNull(nm);
if (use_names) {
posn = INTEGER(PROTECT(matchnames(Snames,nm,"state variables"))); nprotect++;
}
ap = REAL(AS_NUMERIC(ans));
first = 0;
} else {
ap = REAL(AS_NUMERIC(eval(fcall,rho)));
}
if (use_names) {
for (i = 0; i < nvars; i++) xm[posn[i]] = ap[i];
} else {
for (i = 0; i < nvars; i++) xm[i] = ap[i];
}
}
break;
case native: // native code
(*ff)(xm,pm,sidx,pidx,cidx,ncovars,cp,t,dt);
break;
default:
errorcall(R_NilValue,"unrecognized 'mode' %d",mode); // # nocov
break;
}
}
t += dt;
if ((meth == 0) && (k == nstep-2)) { // penultimate step
dt = time[step]-t;
t = time[step]-dt;
}
}
}
}
if (mode==1) {
PutRNGstate();
unset_pomp_userdata();
}
UNPROTECT(nprotect);
return X;
}
/*!
\author Hanne Rognebakke
\brief Writes COST data after using the routine makedata_COST
Only to be used for testing.
*/
int write_input_model1_COST(Data_orig *i_D_orig, Data_COST *i_D_COST,
SEXP i_ageList,SEXP i_lgaList,SEXP i_priorList)
{
SEXP elmt = R_NilValue;
int a,h,i,nBoatsObs,nBoatsMl,nFishObs,nFishMl,n,nFish;
FILE *caa_input;
int nAges;
int *a_vec;
int lga_g_a_model,lga_g_a_ncat;
int *lga_g_a_a2Age_vec;
double *lga_g_a_avec,*lga_g_a_par_init;
caa_input = fopen("caa_input_model1_COST.txt","w");
if(!Rf_isNull(elmt = getListElement(i_ageList, "nAges")))
nAges = INTEGER_VALUE(elmt);
if(!Rf_isNull(elmt = getListElement(i_ageList, "a_vec")))
a_vec = INTEGER_POINTER(AS_INTEGER(elmt));
fprintf(caa_input,"nAges=%d\n",nAges);
for(a=0;a<nAges;a++)
fprintf(caa_input,"a_vec[%d]=%d\n",a,a_vec[a]);
lga_g_a_model = INTEGER_VALUE(getListElement(i_lgaList, "g_a_model"));
lga_g_a_ncat = INTEGER_VALUE(getListElement(i_lgaList,"g_a_ncat"));
lga_g_a_a2Age_vec = INTEGER_POINTER(AS_INTEGER(getListElement(i_lgaList,"g_a_a2Age_vec")));
lga_g_a_avec = NUMERIC_POINTER(getListElement(i_lgaList,"g_a_avec"));
fprintf(caa_input,"g_a_model=%d\n",lga_g_a_model);
for(a=0;a<lga_g_a_ncat;a++)
fprintf(caa_input,"lga_g_a_a_vec[%d]=%f\n",a,lga_g_a_avec[a]);
for(a=0;a<nAges;a++)
fprintf(caa_input,"lga_g_a_a2Age_vec[%d]=%d\n",a,lga_g_a_a2Age_vec[a]);
if(lga_g_a_model == 1)
{
if(!Rf_isNull(elmt = getListElement(i_lgaList, "g_a_par_init")))
lga_g_a_par_init = NUMERIC_POINTER(elmt);
fprintf(caa_input,"g_a_par_init\n");
fprintf(caa_input,"c=%f,theta=%f,gamma=%f\n",lga_g_a_par_init[0],
lga_g_a_par_init[1],lga_g_a_par_init[2]);
}
fprintf(caa_input,"n_int_len_lim=%d\n",i_D_orig->n_int_len);
for(i=0;i<i_D_orig->n_int_len;i++)
fprintf(caa_input,"%f\n",i_D_orig->int_len_lim[i]);
fprintf(caa_input,"Observer data\n");
nBoatsObs = i_D_COST->obs->n_trip;
fprintf(caa_input,"Number of trips=%d\n",nBoatsObs);
nFishObs = 0;
nFish = 0;
for(h=0;h<nBoatsObs;h++)
{
fprintf(caa_input,"i=%d,nFishBoat=%d,start_Age=%d,start_noAge=%d,num_noAge=%d,season=%d,ndisc=%d,nland=%d\n",
h,i_D_orig->nFishBoat[h],i_D_orig->start_Age[h],i_D_orig->start_noAge[h],
i_D_orig->num_noAge[h],i_D_orig->season[h],
i_D_orig->n_discard[h],i_D_orig->n_landed[h]);
nFishObs += i_D_orig->nFishBoat[h];
nFish += i_D_orig->n_landed[h];
}
fprintf(caa_input,"n_landed_tot=%d\n",nFish);
fprintf(caa_input,"n=%d,trip[i],totage[i],totlength[i],replength[i],discard[i],landed[i]:\n",
nFishObs);
h = 0;
n = i_D_orig->nFishBoat[0]-1;
for(i=0;i<nFishObs;i++)
{
fprintf(caa_input,"%d,%d,%d,%f,%d,%d,%d\n",i,h,
i_D_orig->totage[i],i_D_orig->totlength[i],i_D_orig->replength[i],
i_D_orig->discard[i],i_D_orig->landed[i]);
if(i==n)
{
h++;
n += i_D_orig->nFishBoat[h];
}
}
fprintf(caa_input,"Market landing data\n");
nBoatsMl = i_D_COST->mland->n_trip;
fprintf(caa_input,"Number of trips=%d\n",nBoatsMl);
nFishMl = 0;
nFish = 0;
for(h=nBoatsObs;h<nBoatsObs+nBoatsMl;h++)
{
fprintf(caa_input,"i=%d,nFishBoat=%d,start_Age=%d,start_noAge=%d,num_noAge=%d,season=%d,ndisc=%d,nland=%d\n",
h,i_D_orig->nFishBoat[h],i_D_orig->start_Age[h],i_D_orig->start_noAge[h],
i_D_orig->num_noAge[h],i_D_orig->season[h],
i_D_orig->n_discard[h],i_D_orig->n_landed[h]);
nFishMl += i_D_orig->nFishBoat[h];
nFish += i_D_orig->n_landed[h];
}
fprintf(caa_input,"n_landed_tot=%d\n",nFish);
fprintf(caa_input,"n=%d,trip[i],totage[i],totlength[i],replength[i],discard[i],landed[i]:\n",
nFishMl);
h = nBoatsObs;
for(i=nFishObs;i<nFishObs+nFishMl;i++)
{
fprintf(caa_input,"%d,%d,%d,%f,%d,%d,%d\n",i,h,i_D_orig->totage[i],
i_D_orig->totlength[i],i_D_orig->replength[i],
i_D_orig->discard[i],i_D_orig->landed[i]);
if(i==n && i<nFishObs+nFishMl-1)
{
h++;
n += i_D_orig->nFishBoat[h];
}
}
fclose(caa_input);
return(0);
} /* end of write_input_model1_COST */
SEXP simulateprofiles(SEXP N, SEXP weights, SEXP Rules, SEXP f_pr_and, SEXP act_fun, SEXP alpha, SEXP beta, SEXP lambda, SEXP Xmin, SEXP Xmax, SEXP X0, SEXP param, SEXP ko_experim, SEXP sd_noise, SEXP times, SEXP stat_thr, SEXP stat_width, SEXP method, SEXP ext_in, SEXP ext_fun, SEXP num_exp, SEXP save)
{
int i, j, k, k1, m, f, nf, ll, llr, llf, nProtected = 0, N1;
double min_xzero, max_xzero;
double stat_thr1, stat_width1;
int stat;
int save1, num_exp1, ko = 0, max_lengthR;
double p1[MAXPAR], p2[MAXPAR], tmp;
VETTOREd *parm[MAXPAR], *param_orig[2];
double sd_noise1;
VETTOREd *lambda1 = NULL, *X01 = NULL, *X02 = NULL, *Xmin1 = NULL, *Xmax1 = NULL, *alpha1 = NULL, *beta1 = NULL, *times1 = NULL;
VETTOREi *param1 = NULL, *ko_experim1 = NULL, *ko_experim2 = NULL;
MATRICEd *weights1 = NULL, *weights2 = NULL, *ext_in1 = NULL, *ris1 = NULL;
LISTA *r1 = NULL, *r2 = NULL, *ext_fun1 = NULL;
GString *f_pr_and1 = NULL, *act_fun1 = NULL, *method1 = NULL;
char buf[25];
char etich[50];
char err[256];
int pad_reti, pad_exp, pad_ko, num_ko;
bool regole_nulle = false;
SEXP ris;
muParserHandle_t hParser, *hParsers = NULL;
#ifdef MDEBUG
GString **nomi;
char tmp1[10];
#endif
VETTOREd *parm0[MAXPAR] = { NULL, NULL, NULL, NULL, NULL, NULL };
_InitDbg(false, false, false);
_Intestazione("\n*** simulateprofiles ***\n");
N1 = INTEGER_VALUE(N);
weights1 = inMATRICE_d(weights, &nProtected);
llr = length(Rules);
llf = length(ext_fun);
ll = max_s_i(llr, llf);
#ifdef MDEBUG
nomi = mia_alloc(ll, GString *);
if (ll > 0 && nomi == NULL) {
Rprintf("Not enough memory (simulateprofiles # %d, nomi)", __LINE__ - 2);
error("");
}
#endif
for (i = 0; i < ll; i++) {
#ifdef MDEBUG
if (i < llr)
snprintf(tmp1, 10, "Lista r %d", i + 1);
else
tmp1[0] = '\0';
CREAstr(nomi[i], tmp1);
#endif
}
r2 = inLISTA(Rules, &nProtected, llr, NULL, nomi);
if (g_tipi == NULL) {
g_ntipi = llf;
g_tipi = mia_alloc(llf, enum TIPO);
if (llf > 0 && g_tipi == NULL) {
Rprintf("Not enough memory (simulateprofiles # %d, tipi)", __LINE__ - 2);
error("");
}
}
SEXP FixDetectC(SEXP X, SEXP Y, SEXP R, SEXP Dispersion, SEXP MinDur, SEXP Debug)
{
//function input
double *pDisp = REAL(Dispersion);
double *pMinDur = REAL(MinDur);
int fDebug;
//function output
double *res = NULL;
SEXP Res,r_X,r_Y,r_D,r_dur,r_start,r_disp;
SEXP list_names;
//detection parameters =================================================
int MinDuration; //min dispersion duration (samples)
float Threshold; //dispersion threshold
float Xi,Yi; //X & Y coordinates
int bGaze; //valid data flag
//LC detector output =============================================================
float X_d,Y_d,FixX,FixY;
float Deviation_d;
int SaccadeDuration,FixDuration;
int bGaze_d;
int rc; //return code
//=================================
char *names[6] = {"X","Y","R","Dur","Start","Disp"};
int i,len,lmax,iend,istart;
float Ri, dMean; //current and average pupil size
int j, Dcnt; //after-detection pupil size and dispersion calculation
int MaxNFix, NFix;
struct _stFIXdata *pFIX_b, *pFIX;
size_t FIXdata_sz;
float fDx,fDy,dDrSq,fD,fDisp;
fDebug = INTEGER_VALUE(Debug); //Flag - debug
MinDuration = (int) *pMinDur;
Threshold = (float) *pDisp;
len=LENGTH(X);
lmax=len - 1;
i=0;
MaxNFix = len / MinDuration;
if (fDebug > 0) Rprintf("FixDetectC start: len =%d MaxNFix=%d \n",len,MaxNFix);
FIXdata_sz = MaxNFix*sizeof(struct _stFIXdata);
pFIX_b = (struct _stFIXdata *) malloc(FIXdata_sz);
if (pFIX_b == NULL) {
Rprintf("FixDetectC: memory allocation ERROR (fixations BLOCK allocation)\n");
PROTECT(Res = allocVector(REALSXP, 1));
res = REAL(Res);
*res = 0;
UNPROTECT(1);
return Res;
}
pFIX = pFIX_b;
NFix=0;
if (fDebug > 0) Rprintf("FixDetectC: InitFication Call\n");
InitFixation(MinDuration);
if (fDebug > 0) Rprintf("FixDetectC: main while(i < len) \n");
while (i < len) {
Xi = (float) REAL(X)[i];
Yi = (float) REAL(Y)[i];
Ri = (float) REAL(R)[i];
if (Ri > 0) bGaze = 1; else bGaze = 0;
rc=DetectFixation(bGaze,Xi,Yi,Threshold,MinDuration,&bGaze_d,&X_d,&Y_d,&Deviation_d,&FixX,&FixY,&SaccadeDuration,&FixDuration);
if (fDebug > 1) Rprintf("FixDetectC DetectFixation %d,%d,%4.2f,%4.2f\n",i,rc,Xi,Yi);
if ((rc == 2)||((rc == 1)&&(i == lmax)) ) {
//--- Fixation finished -----
iend = i - MinDuration;
istart = iend - FixDuration + 1;
// Вычисляем средний диаметр зрачка
j = 0; Dcnt=0; dMean=0; fD = 0; fDisp=0;
for (j = istart; j < iend; j++) {
Ri = (float) REAL(R)[j];
Xi = (float) REAL(X)[j];
Yi = (float) REAL(Y)[j];
if (Ri > 0) { Dcnt++; dMean += Ri; }
fDx = FixX - Xi;
fDy = FixY - Yi;
dDrSq = fDx * fDx + fDy * fDy;
fD = fD + dDrSq;
}
if (Dcnt >0) dMean = dMean / Dcnt;
if (Dcnt > 1) fDisp = (float)sqrt(fD / (Dcnt - 1));
// Выводим информацию о фиксации
if (fDebug > 0) Rprintf("FixDetectC fixation: %4.2f,%4.2f,%3.5f,%d,%d\n",FixX,FixY,dMean,istart,FixDuration);
if (FixDuration >= MinDuration) {
pFIX->fixx = FixX;
pFIX->fixy = FixY;
pFIX->D = dMean;
pFIX->duration = FixDuration;
pFIX->start = istart;
pFIX->fixdisp = fDisp;
if ( NFix < MaxNFix) {pFIX++; NFix++;}
else {
Rprintf("FixDetectC: ERROR NFix (%d) == MaxNFix (%d)",NFix,MaxNFix);
break;
}
}
}
i++;
}
if (fDebug > 1) Rprintf("FixDetectC main loop finished\n");
PROTECT(Res = allocVector(VECSXP,6));
PROTECT(r_X = allocVector(REALSXP,NFix));
PROTECT(r_Y = allocVector(REALSXP,NFix));
PROTECT(r_D = allocVector(REALSXP,NFix));
PROTECT(r_dur = allocVector(INTSXP,NFix));
PROTECT(r_start = allocVector(INTSXP,NFix));
PROTECT(r_disp = allocVector(REALSXP,NFix));
PROTECT(list_names = allocVector(STRSXP,6));
//=======
pFIX = pFIX_b;
i=0;
while (i<NFix) {
REAL(r_X)[i] = pFIX->fixx;
REAL(r_Y)[i] = pFIX->fixy;
REAL(r_D)[i] = pFIX->D;
INTEGER(r_dur)[i] = pFIX->duration;
INTEGER(r_start)[i] = pFIX->start;
REAL(r_disp)[i] = pFIX->fixdisp;
pFIX++; i++;
}
SET_VECTOR_ELT(Res,0,r_X);
SET_VECTOR_ELT(Res,1,r_Y);
SET_VECTOR_ELT(Res,2,r_D);
SET_VECTOR_ELT(Res,3,r_dur);
SET_VECTOR_ELT(Res,4,r_start);
SET_VECTOR_ELT(Res,5,r_disp);
//== Set names for output LIST elements ===========================
for(i = 0; i < 6; i++) SET_STRING_ELT(list_names,i,mkChar(names[i]));
setAttrib(Res, R_NamesSymbol, list_names);
UNPROTECT(8);
free(pFIX_b);
return Res;
}
SEXP zSplitByFixedSizeBars(SEXP xIntVect, SEXP nBy, SEXP nCount)
{
int i, j, N, NBy, intSplitTo, intSplitTo2, startI;
long long int sum=0;
int *pNUM, *pResult;
SEXP result;
PROTECT(xIntVect = AS_INTEGER(xIntVect));
NBy = INTEGER_VALUE(nBy);
N = INTEGER_VALUE(nCount);
pNUM = INTEGER(xIntVect);
//get sum
for(i=0; i<N; i++)
{
sum += pNUM[i];
}
//how many rows we'll need to split the volume bars to
intSplitTo = sum/NBy;
if(sum % NBy > 0)
intSplitTo += 1;
//reserve space for the results
PROTECT(result = allocMatrix(INTSXP, intSplitTo, 3));
pResult = INTEGER(result);
intSplitTo2 = intSplitTo * 2;
//split
j=0; //j is the index for the split matrix
i=0; // i is the index of the original vector
sum = 0;
startI = 1;
while(1)
{
if(sum >= NBy) //split
{
pResult[j] = startI;
pResult[j+intSplitTo] = i;
pResult[j+intSplitTo2] = NBy;
sum -= NBy;
if(sum == 0)
startI = i+1;
else
startI = i;
j++;
continue;
}
if(i==N && sum <= NBy) {
if(sum != 0) { // final split
pResult[intSplitTo-1] = startI;
pResult[intSplitTo2-1] = i;
pResult[intSplitTo*3-1] = sum;
}
break;
}
if(i<N) {
sum += pNUM[i];
i++;
}
}
UNPROTECT(2);
return result;
}
/* just the interface function */
SEXP computeStandardEyemeasuresExt(SEXP positionsArg, SEXP fixationTimesArg,
SEXP fixationStartArg, SEXP fixationEndArg,
SEXP trialIdArg, SEXP trialInfoArg,
SEXP nrOfROIsArg, SEXP nrOfTrialsArg,
SEXP cutoffArg, SEXP cutoffLengthArg,
SEXP regressiveFirstPassArg, SEXP useTimeIntervalsArg)
{
LOG(("<computeStandardEyemeasuresExt>\n"))
/* process arguments */
CStandardMeasures m(positionsArg, fixationTimesArg,
fixationStartArg, fixationEndArg,
trialIdArg, trialInfoArg,
nrOfROIsArg, nrOfTrialsArg,
cutoffArg, cutoffLengthArg,
useTimeIntervalsArg );
bool regressiveFirstPass = LOGICAL_VALUE(regressiveFirstPassArg);
int nrOfTrials = INTEGER_VALUE(nrOfTrialsArg);
if(nrOfTrials < 0) nrOfTrials = 0;
/* do computations */
m.computeStandardEyemeasures(regressiveFirstPass);
// handle returning stuff
SEXP listRet, listNamesRet;
const int resultVectorsCnt = 1 + 14; // 1 extra for roi
// set the names vector
SPROTECT(listNamesRet = allocVector(STRSXP, resultVectorsCnt+length(trialInfoArg)));
SPROTECT(listRet = allocVector(VECSXP, resultVectorsCnt+length(trialInfoArg)));
// add info elements
SEXP trialInfoNames = getAttrib(trialInfoArg, R_NamesSymbol);
int rListAppendCnt=0;
for( int i=0; i < length(trialInfoArg); i++)
APPEND_RET_VEC ( CHAR(STRING_ELT(trialInfoNames, i)), m.trialInfoR[i]);
// add result vectors
APPEND_RET_VEC( "roi", m.positionsR); // attaching ROIs vector to list
APPEND_RET_VEC( "FFD", m.ffdR); // FFD (first fixation duration)
APPEND_RET_VEC( "FFP", m.ffpR); // FFP (first fixation progressive)
APPEND_RET_VEC( "SFD", m.sfdR); // SFD (single fixation duration)
APPEND_RET_VEC( "FPRT", m.fprtR); // FPRT (first pass reading time / gaze duration)
APPEND_RET_VEC( "RBRT", m.rbrtR); // RBRT (right bounded reading time)
APPEND_RET_VEC( "TFT", m.tftR); // TFT (total fixation time)
APPEND_RET_VEC( "RPD", m.rpdR); // RPD (regression path duration)
APPEND_RET_VEC( "CRPD", m.crpdR); // CRPD (cumulative regression path duration)
APPEND_RET_VEC( "RRT", m.rrtR); // RRT (re-reading time)
APPEND_RET_VEC( "RRTP", m.rrtpR); // RRTP (re-reading time progressive)
APPEND_RET_VEC( "RRTR", m.rrtrR); // RRTR (re-reading time regressive)
APPEND_RET_VEC( "RBRC", m.rbrcR); // RBRC (first-pass regression count)
APPEND_RET_VEC( "TRC", m.trcR); // TRC (total regression count)
APPEND_RET_VEC( "LPRT", m.lprtR); // LPRT (last pass reading time)
setAttrib(listRet, R_NamesSymbol, listNamesRet); //and attaching the vector names
UNPROTECT_PTR(listRet);
UNPROTECT_PTR(listNamesRet);
LOG(("</computeStandardEyemeasuresExt>\n"))
return(listRet);
}
SEXP docDF(SEXP directory,
SEXP origF,
SEXP fileN,
SEXP ft,
SEXP type,
SEXP pos,
SEXP posN,
SEXP minFreq,
SEXP N,
// SEXP sym,
// SEXP kigo,
SEXP Genkei,
SEXP nDF,
SEXP mydic ){
// Rprintf("BUF1 = %i\n", BUF1); //
// Rprintf("BUF2 = %i\n", BUF2); //
// Rprintf("BUF3 = %i\n", BUF3); //
// Rprintf("BUF4 = %i\n", BUF4); //
// Rprintf("FILEINPUT = %i\n", FILEINPUT); //
int file = 0, n0 = 0, i = 0, j = 0, pc = 0, xx = 1;
const char* dic = CHAR(STRING_ELT(mydic, 0));//指定辞書
int f_count = INTEGER_VALUE( fileN );//ファイル(行)数
char* path = 0;// 2011 03 11 char* path;
// 2011 03 10 // char * f[f_count];
vector <string> ff;
//const char* KIGO = CHAR(STRING_ELT(kigo,0));
int typeSet = INTEGER_VALUE( type );// 形態素か，品詞か，文字か
int Ngram = INTEGER_VALUE( N );// N の数
int mFreq = INTEGER_VALUE( minFreq );// 最小頻度の数
if(mFreq < 1){
mFreq = 1;
}
//int mSym = INTEGER_VALUE( sym );// 記号を含めるか 0 含めない;1 含める
int NDF = INTEGER_VALUE( nDF );// データフレームの列数
int genkei = INTEGER_VALUE( Genkei );// 活用は原型か 0 表層形か 1
char file_name[FILEN];
char input[BUF4];
char * p;
string str;
char buf1[BUF1];// [512];//入力された語形を記憶
// char buf2[1024];
char buf3[BUF1];// [512];品詞チェック用
char buf4[BUF1];// [1024];品詞チェック用
SEXP tmp, row_names, mydf = R_NilValue, varlabels = R_NilValue;// 2011 03 11 // SEXP mydf, tmp, row_names, varlabels;// SEXP ans, dim, dimnames, row_names, col_names;
int mFt = INTEGER_VALUE( ft );// ファイル 0 かディレクトリ 1 かデータフレーム列か2
/////
FILE *fp;// 2009 04 03
map<string, int> ma0;//, ma[f_count]; // ファイル数の数+登録単語用マップの数1
vector <map<string, int> > vecmap;// 2011 03 09
for (i = 0; i < f_count; i++) vecmap.push_back(map<string, int>() );
map<string, int>::iterator pma0, pma;// マップ検索用
list <string> hinsi, strL, saibun;
list <string>::iterator hinsi_it, iter, saibun_it;// 2009 04 03
/////
// Rprintf("f_file = %i\n", f_count); // 2011 03 09
PROTECT(directory = AS_CHARACTER(directory));pc++;
PROTECT(origF = AS_CHARACTER(origF));pc++;//ファイル名//各列文字の処理
if(mFt == 1 || mFt == 0 ){// ファイル 0 かディレクトリ 1
path = R_alloc(strlen(CHAR(STRING_ELT(directory, 0))), sizeof(char));//ディレクトリ名
strcpy(path, CHAR(STRING_ELT(directory, 0)));
// 2011 03 10 // for(file = 0; file < f_count; file++){
// 2011 03 10 // f[file] = R_alloc(strlen(CHAR(STRING_ELT(origF, file))), sizeof(char));
// 2011 03 10 // }
for(file = 0; file < f_count; file++){
// 2011 03 10 // strcpy(f[file], CHAR(STRING_ELT(origF, file)));
ff.push_back(CHAR(STRING_ELT(origF, file)));
// 2011 03 10 // Rprintf("f[file] = %s\n", f[file]); // 2011 03 09
// 2011 03 10 // Rprintf("ff[file] = %s\n", ff[file].c_str()); // 2011 03 09
}
}
// Rprintf("after loop: f[1] = %s\n", f[1]); // 2011 03 09
int pos_n = INTEGER_VALUE( posN );// pos の数 // 2005 06 3
// bool flag = 1;
// if(pos_n == 0){
// pos_n = 1;
// flag = 0;
// }
// 2011 03 10 // char *Ppos[pos_n];
vector <string> Ppos2;
SEXP myPos;
if(pos_n > 0){// if(flag){//if(pos_n > 0){}
PROTECT(myPos = AS_CHARACTER(pos));pc++;
// 2011 03 10 // for( i = 0; i < pos_n; i++){
// 2011 03 10 // Ppos[i] = R_alloc(strlen(CHAR(STRING_ELT(myPos, i))), sizeof(char));
// 2011 03 10 // }
// Rprintf("end myPos = AS_CHARACTER(pos) \n");
for( i = 0; i < pos_n; i++){
// 2011 03 10 // strcpy(Ppos[i], CHAR(STRING_ELT(myPos, i)));
Ppos2.push_back (CHAR(STRING_ELT(myPos, i)) ) ;// 2011 03 10
// Rprintf("Pos[%d] = %s\n", i, Ppos[i]);
}
}// 2005 06 23
else{
// 2011 03 10 // Ppos[pos_n] = '\0';
myPos = NULL;
// strcpy(buf3 , meisiCode());
// // if (strcmp(buf3, "名詞") == 0){
// // Rprintf("%s\n", buf3);
// // }
// PROTECT(myPos = allocVector(STRSXP, 1));pc++;
// SET_STRING_ELT(myPos, 0, mkCharCE(buf3, (utf8locale)?CE_UTF8:CE_NATIVE ));
// Ppos[0] = R_alloc(strlen(CHAR(STRING_ELT(myPos, 0))), sizeof(char));
// strcpy(Ppos[0], CHAR(STRING_ELT(myPos, 0)));
}
// FILE *fp;
// map<string, int> ma0, ma[f_count]; // ファイル数の数+登録単語用マップの数1
// map<string, int>::iterator pma0, pma;// マップ検索用
// list <string> hinsi, strL, saibun;
// list <string>::iterator hinsi_it, iter, saibun_it;
// Rprintf("after loop2: f[1] = %s\n", f[1]); // 2011 03 09
for(file = 0; file < f_count; file++) {
// Rprintf("in for loop: file = %i :f[file] = %s\n", file, f[file] ); // 2011 03 09
if(mFt == 2){//データフレームのベクトル
if( strlen(CHAR(STRING_ELT(origF, file))) < 1 || STRING_ELT(origF, file) == NA_STRING ) {
// Rprintf("in ISNA\n");
continue;
}
//input = (char []) R_alloc(strlen(CHAR(STRING_ELT(directory, file))), sizeof(char));
strcpy(input , CHAR(STRING_ELT(origF, file)));
//Rprintf("to setMeCabMap\n");
pma0 = ma0.begin();
pma = (vecmap.at(file)).begin();// ma[file].begin();
strL.clear();
hinsi.clear();
saibun.clear();
//setMeCabMap(typeSet, input, ma0, ma[file], pma0, pma, strL, iter, hinsi, hinsi_it, saibun, saibun_it, Ppos, pos_n, mSym, KIGO, Ngram, genkei);
setMeCabMap(typeSet, input, ma0, vecmap.at(file), pma0, pma, strL, iter, hinsi, hinsi_it, saibun, saibun_it, Ppos2, pos_n, Ngram, genkei, dic);
////////////////////////////////////////////////
}else if(mFt == 0 || mFt ==1){// ファイル 0 かディレクトリ 1
// Rprintf("file = %i: f[file] = %s\n", file, f[file]); // 2011 03 09
// sprintf(file_name, "%s/%s", path, f[file]);
sprintf(file_name, "%s/%s", path, ff[file].c_str());
// Rprintf("file_name = %s not found\n",file_name);// 2011 03 09
if(strcmp(file_name, "") == 0){
continue;
}
if((fp = fopen(file_name, "r")) == NULL){
Rprintf("NULL! %s not found\n",file_name);
UNPROTECT(pc);
return(R_NilValue);
}else{
//strL.clear();
Rprintf("file_name = %s opened\n", file_name );
while(!feof(fp)){
//Rprintf("fgets\n");
if(fgets(input, FILEINPUT, fp) != NULL){// 2011 03 11 if(fgets(input, 5120, fp) != NULL){
if(strlen(input) < 1){
continue;
}
// Rprintf("to setMeCabMap\n");
pma0 = ma0.begin();
pma = (vecmap.at(file)).begin();// ma[file].begin();
strL.clear();
hinsi.clear();
saibun.clear();
//setMeCabMap(typeSet, input, ma0, ma[file], pma0, pma, strL, iter, hinsi, hinsi_it, saibun, saibun_it, Ppos, pos_n, mSym, KIGO, Ngram, genkei);
setMeCabMap(typeSet, input, ma0, vecmap.at(file), pma0, pma, strL, iter, hinsi, hinsi_it, saibun, saibun_it, Ppos2, pos_n, Ngram, genkei, dic);
////////////////////////////////////////////////
}
}//while(feop)
fclose(fp);
} //else//
}//else if(mFt == 0 || mFt ==1){// for(file);
}//for
////////////// MeCab の処理終了
// 最低頻度のチェック
pma0 = ma0.begin();
while( pma0 != ma0.end() ){
if(pma0->second < mFreq){
ma0.erase(pma0++);///// ma0.erase(pma0);// 2007 09 15 // ma0.erase(pma0++);
}else{
++pma0;
}
}
n0 = (int)ma0.size();// ターム数のチェック
if(n0 > OVERLINE ){ // 40000 -> OVERLINE // 2016 12 27
Rprintf("Warning! number of extracted terms = %d\n", n0);
}else{
Rprintf("number of extracted terms = %d\n", n0);
Rprintf("now making a data frame. wait a while!\n");
}
if(n0 < 1){
Rprintf("no terms extracted\n");
UNPROTECT(pc);
return(R_NilValue);
}
//////////////////// データフレームの作成
// Rprintf("nn = %d\n", nn);
if(typeSet == 0 || typeSet == 2){
PROTECT(mydf = allocVector(VECSXP, 1 + f_count));pc++;
SET_VECTOR_ELT(mydf, 0, allocVector(STRSXP, n0));//文字gram or 品詞gram
for(file = 0; file < f_count; file++){
SET_VECTOR_ELT(mydf, file+1, allocVector(INTSXP, n0));// 頻度
}
//文字組 + ファイル数のdata.frame // 列数
}else if(typeSet == 1){
if(NDF == 1){//名詞組を独立したデータフレーム列として返す場合
i = Ngram + 2 + f_count;
PROTECT(mydf = allocVector(VECSXP, i ));pc++;
for(j = 0; j < i ; j++){
if(j < Ngram +2){
SET_VECTOR_ELT(mydf, j, allocVector(STRSXP, n0));//単語列
}else{
SET_VECTOR_ELT(mydf, j, allocVector(INTSXP, n0));// 頻度
}
}
}else{//名詞組-品詞組ｰ再分類1 + ファイル数のdata.frame // 列数
PROTECT(mydf = allocVector(VECSXP, 3 + f_count));pc++;//名詞組-品詞組ｰ再分類1 + ファイル数のdata.frame // 列数
SET_VECTOR_ELT(mydf, 0, allocVector(STRSXP, n0));//単語列
SET_VECTOR_ELT(mydf, 1, allocVector(STRSXP, n0));//品詞列
SET_VECTOR_ELT(mydf, 2, allocVector(STRSXP, n0));//細目列
for(file = 0; file < f_count; file++){
SET_VECTOR_ELT(mydf, file+3, allocVector(INTSXP, n0));// 頻度
}
}
}
//Rprintf("data frame made\n");
///各列の代入開始
//Rprintf("data frame made\n");
///各列の代入開始
if(mydf == NULL){
Rprintf("NULL");
}
if(typeSet == 0){//文字の場合
pma0 = ma0.begin();
for (xx = 0; xx < n0 && pma0 != ma0.end(); xx++) {// n0 行のタームの数だけ繰り返す
strcpy(buf3, (pma0->first).c_str());
//Rprintf("before column");
//先頭列の xx 行に 文字組をセット
// #if defined(WIN32)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, 0), xx, mkCharCE( buf3, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, 0), xx, mkCharCE( buf3, CE_NATIVE ));
// #else
// SET_VECTOR_ELT(VECTOR_ELT(mydf, 0), xx, mkCharCE( buf3, CE_UTF8 ));
// #endif
SET_STRING_ELT(VECTOR_ELT(mydf, 0), xx, mkCharCE( buf3, (utf8locale)?CE_UTF8:CE_NATIVE ));// < 2006 04 18>
//Rprintf("column 0 is finished");
// 各ファイルから探し出してその頻度を新規列に追加
for(file = 0; file < f_count && pma0 != ma0.end(); file++){
pma = (vecmap.at(file)).begin();// ma[file].begin();
pma = (vecmap.at(file)).find( (pma0->first).c_str() );// ma[file].find( (pma0->first).c_str() );
if(pma != (vecmap.at(file)).end()){// if(pma != ma[file].end()){// 見つかった
INTEGER(VECTOR_ELT(mydf, 1+file))[xx] = pma->second;// 新規列に追加
}
else{
INTEGER(VECTOR_ELT(mydf, 1+file))[xx] = 0;// 新規列に追加
}
}
//Rprintf("column %d is finished", (file+1));
pma0++;
//if(xx % 10 == 0) Rprintf("* ");// 2006 03 27
} //////////////////////////////
}else if(typeSet == 1 ){//タームの場合
pma0 = ma0.begin();
buf3[0] = '\0';
for (xx = 0; xx < n0; xx++) {//n0 行のタームの数だけ繰り返す
strcpy(buf4, (pma0->first).c_str());// 最初の要素の文字列を取得し
p = strtok(buf4 , " " );//タームの内容を Ngramずつ区切る
// Rprintf("buf4 = %s - ", buf4);
j = 0;
i = 1;
//str.erase();
while(p != NULL){// _TYPE_1
if(NDF == 1 && i <= Ngram ){//タームはデータフレーム形式で
sprintf(buf3, "%s", p);
// #if defined(WIN32)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));//j列のxx行にセット
// #elif defined(__MINGW32__)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));
// #else
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_UTF8 ));
// #endif
SET_STRING_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, (utf8locale)?CE_UTF8:CE_NATIVE ));// < 2006 04 18>
//Rprintf("buf3 = %s \n", buf3);
i++;
p = strtok( NULL, " ");
buf3[0] = '\0';
continue;
}
if( (i % Ngram) == 0){
//sprintf(buf3, "%s", str);
strcat(buf3,p);
// Rprintf("buf3 = %s \n", buf3);
// #if defined(WIN32)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));//j列のxx行にセット
// #elif defined(__MINGW32__)
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));
// #else
// SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_UTF8 ));
// #endif
SET_STRING_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, (utf8locale)?CE_UTF8:CE_NATIVE ));//j列のxx行にセット < 2006 04 18>
//str.erase();
buf3[0] = '\0';
//++i;
}else{
strcat(buf3, p);
strcat(buf3, "-");
//str.append(p);
//str.append("-");
//++i;
}
// // // sprintf(buf3, "%s", p);// 名詞組，品詞組,細分組の取得
// // // // Rprintf("buf3 = %s\n", buf3);
// // // #if defined(WIN32)
// // // SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));//j列のxx行にセット
// // // #elif defined(__MINGW32__)
// // // SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_NATIVE ));
// // // #else
// // // SET_VECTOR_ELT(VECTOR_ELT(mydf, j++), xx, mkCharCE( buf3, CE_UTF8 ));
// // // #endif
p = strtok( NULL, " ");
++i;
// if( j >= 2){
// continue;
// }
}//////while(p != NULL) _TYPE_1 //////////////////////////////
/////////////////////////////////////////////////
// 各ファイルから探し出してその頻度を新規列に追加
for(file = 0; file < f_count && pma0 != ma0.end(); file++){
pma = (vecmap.at(file)).begin(); // ma[file].begin();
pma = (vecmap.at(file)).find( (pma0->first).c_str() );// ma[file].find( (pma0->first).c_str() );
if(pma != (vecmap.at(file)).end()){// if(pma != ma[file].end()){// 見つかった
if(NDF == 1){
INTEGER(VECTOR_ELT(mydf, Ngram+2+file))[xx] = pma->second;// 新規列に追加
}else{
INTEGER(VECTOR_ELT(mydf, 3+file))[xx] = pma->second;//
}
}
else{
if(NDF == 1){
INTEGER(VECTOR_ELT(mydf, Ngram+2+file))[xx] = 0;// 新規列に追加
}else{
INTEGER(VECTOR_ELT(mydf, 3+file))[xx] = 0;// 新規列に追加
}
}
}
pma0++;
// if(xx % 10 == 0) Rprintf("* ");// 2006 03 27 removed 2007 05
}// for (xx = 0; xx < n0; xx++) //n0 行のタームの数だけ繰り返す
}// else if(typeSet == 1 )//タームの場合
//Rprintf("frequnecy made\n");
//df 列ベクトルの名前を用意
// その単純な初期化
if(typeSet == 0){//文字グラムの場合
PROTECT(varlabels = allocVector(STRSXP, 1+f_count)); pc++;
// Rprintf("col names allocated\n");
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, 0, mkCharCE( "Ngram", CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, 0, mkCharCE( "Ngram", CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, 0, mkCharCE( "Ngram", CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, 0, mkCharCE( "Ngram", (utf8locale)?CE_UTF8:CE_NATIVE ));
//Rprintf("first col names set\n");
// 各ファイルあるいは行ごとの名前を設定
for(j = 0; j < f_count; j++){
if(mFt == 2){//データフレームの場合
sprintf(buf4, "Row%d", j+1);//s
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, j+1, mkCharCE(buf4, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, j+1, mkCharCE(buf4, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, j+1, mkCharCE(buf4, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, j+1, mkCharCE(buf4, (utf8locale)?CE_UTF8:CE_NATIVE ));
}else{//ファイルの場合
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, j+1, mkCharCE(f[j], CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, j+1, mkCharCE(f[j], CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, j+1, mkCharCE(f[j], CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, j+1, mkCharCE(ff[j].c_str(), (utf8locale)?CE_UTF8:CE_NATIVE )); // 2011 03 10 SET_STRING_ELT(varlabels, j+1, mkCharCE(f[j], (utf8locale)?CE_UTF8:CE_NATIVE ));
}
}
}else if(typeSet == 1 ){//タームの場合
if(NDF == 1){
PROTECT(varlabels = allocVector(STRSXP, Ngram + 2 + f_count)); pc++;
for(i = 0; i< (Ngram +2); i++){
if(i < Ngram){
sprintf(buf1, "N%d", i+1);
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, i, mkCharCE( buf1, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, i, mkCharCE( buf1, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, i, mkCharCE( buf1, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, i, mkCharCE( buf1, (utf8locale)?CE_UTF8:CE_NATIVE ));
}else if (i == (Ngram)){
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS1", CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS1", CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS1", CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, i, mkCharCE( "POS1", (utf8locale)?CE_UTF8:CE_NATIVE ));
}else if(i == (Ngram +1) ){
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS2", CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS2", CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, i, mkCharCE( "POS2", CE_UTF8 ));
// #endif
// //SET_STRING_ELT(varlabels, i, mkCharCE( "POS2", CE_NATIVE ));
SET_STRING_ELT(varlabels, i, mkCharCE( "POS2", (utf8locale)?CE_UTF8:CE_NATIVE ));
}
}
}else{// if(NDF == 1)
PROTECT(varlabels = allocVector(STRSXP, 3+f_count)); pc++;
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, 0, mkCharCE( "TERM", CE_NATIVE ));
// SET_STRING_ELT(varlabels, 1, mkCharCE( "POS1", CE_NATIVE ));
// SET_STRING_ELT(varlabels, 2, mkCharCE( "POS2", CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, 0, mkCharCE( "TERM", CE_NATIVE ));
// SET_STRING_ELT(varlabels, 1, mkCharCE( "POS1", CE_NATIVE ));
// SET_STRING_ELT(varlabels, 2, mkCharCE( "POS2", CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, 0, mkCharCE( "TERM", CE_UTF8 ));
// SET_STRING_ELT(varlabels, 1, mkCharCE( "POS1", CE_UTF8 ));
// SET_STRING_ELT(varlabels, 2, mkCharCE( "POS2", CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, 0, mkCharCE( "TERM", (utf8locale)?CE_UTF8:CE_NATIVE ));
SET_STRING_ELT(varlabels, 1, mkCharCE( "POS1", (utf8locale)?CE_UTF8:CE_NATIVE ));
SET_STRING_ELT(varlabels, 2, mkCharCE( "POS2", (utf8locale)?CE_UTF8:CE_NATIVE ));
}
//Rprintf("col names allocated\n");
if(mFt == 0 || mFt == 1){// 各ファイル名を列名として設定
for(j = 0; j < f_count; j++){
sprintf(buf4, "%s", ff[j].c_str());// 2011 03 10 sprintf(buf4, "%s", f[j]);//s
if(NDF == 1){// Ngram 本体はいちいち単独列
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE( buf4, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE( buf4, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE( buf4, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE( buf4, (utf8locale)?CE_UTF8:CE_NATIVE ));
} else{// Ngram 本体は一つでまとまり
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, 3+ j, mkCharCE(buf4, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, 3 +j, mkCharCE(buf4, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, 3 + j, mkCharCE(buf4, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, 3+ j, mkCharCE(buf4, (utf8locale)?CE_UTF8:CE_NATIVE ));
}
}
//Rprintf("file names allocated\n");
} else if(mFt == 2){// 行番号を列名として設定
for(j = 0; j < f_count; j++){
sprintf(buf4, "Row%d", j+1);//
if(NDF == 1){// Ngram 本体はいちいち単独列
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE(buf4, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE(buf4, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE(buf4, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, Ngram + 2 + j, mkCharCE(buf4, (utf8locale)?CE_UTF8:CE_NATIVE ));
}else{
// #if defined(WIN32)
// SET_STRING_ELT(varlabels, 3 + j, mkCharCE(buf4, CE_NATIVE ));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(varlabels, 3 + j, mkCharCE(buf4, CE_NATIVE ));
// #else
// SET_STRING_ELT(varlabels, 3 + j, mkCharCE(buf4, CE_UTF8 ));
// #endif
SET_STRING_ELT(varlabels, 3 + j, mkCharCE(buf4, (utf8locale)?CE_UTF8:CE_NATIVE ));
}
}
}
}//else if(typeset ==1) //タームの場合
Rprintf("\n");// 2006 03 27
//Rprintf("row number n0 = %d\n", n0 );
//Rprintf("after colunm names set\n" );
///////////////////////// new_end
// データフレームの行名を設定．必須
PROTECT(row_names = allocVector(STRSXP, n0));pc++;
//Rprintf("after row names set\n" );
char labelbuff[6];// char labelbuff[5]; 2006 03
for (xx = 0; xx < n0 ; xx++) {
sprintf(labelbuff, "%d", xx+1);
// #if defined(WIN32)
// SET_STRING_ELT(row_names, xx, mkCharCE(labelbuff , CE_NATIVE));
// #elif defined(__MINGW32__)
// SET_STRING_ELT(row_names, xx, mkCharCE(labelbuff , CE_NATIVE));
// #else
// SET_STRING_ELT(row_names, xx, mkCharCE(labelbuff , CE_UTF8));
// #endif
SET_STRING_ELT(row_names, xx, mkCharCE(labelbuff , (utf8locale)?CE_UTF8:CE_NATIVE));
//Rprintf("set row %d\n", xx+1 );
}
//Rprintf("before setAttr\n" );
// データフレームオブジェクト mydf の属性設定
// // オブジェクトはデータフレームだと指定する
PROTECT(tmp = mkString("data.frame")); pc++;//tmpにその属性を一時保存
//Rprintf("data frame made");
setAttrib(mydf, R_ClassSymbol, tmp);
setAttrib(mydf, R_NamesSymbol, varlabels);
setAttrib(mydf, R_RowNamesSymbol, row_names);
//Rprintf("before UNPROTECT\n" );
UNPROTECT(pc);
// Rprintf("UNPROTECT \n");
//free(f);
return (mydf);
// 2006 03 05
// # sym 引数は，抽出タームに句読点なので記号を含めるかを指定する．
// ## デフォルトでは sym = 0 とセットされており，
// ## 記号はカウントされないが，
// ## sym = 1 とすると，記号を含めてカウントした結果が出力される
// ## pos 引数に記号が含まれた場合は自動的に sym = 1 とセットされる
// ///////////////////////////////////////////////////////
}
SEXP GADEM_Analysis(SEXP sequence,SEXP sizeSeq, SEXP accession, SEXP Rverbose,SEXP RnumWordGroup,SEXP RnumTop3mer,SEXP RnumTop4mer,SEXP RnumTop5mer,SEXP RnumGeneration,SEXP RpopulationSize, SEXP RpValue,SEXP ReValue,SEXP RextTrim,SEXP RminSpaceWidth,SEXP RmaxSpaceWidth,SEXP RuseChIPscore,SEXP RnumEM,SEXP RfEM, SEXP RwidthWt,SEXP RfullScan, SEXP RslideWinPWM,SEXP RstopCriterion,SEXP RnumBackgSets,SEXP RweightType,SEXP RbFileName,SEXP RListPWM,SEXP RminSites,SEXP RmaskR,SEXP Rnmotifs)
{
char *bFileName;
SEXP ResultsGadem;
SEXP RSpwm;
PROTECT(ResultsGadem=NEW_LIST(100));
int increment=0;
double testrand;
//Number of sequences
int numSeq = INTEGER_VALUE(sizeSeq);
// const
// char *Fastaheader[size];
int incr=0;
int longueur=length(sequence);
int IncrementTemp=0;
// basic settings/info
int maxSeqLen,*seqLen; // sequence info
double aveSeqLen; // sequence info
char **seq,**rseq;
int *geneID; // sequence info
char **oseq,**orseq; // copy of the original sequences
char **sseq,**rsseq; // simulated seqs.
double *bfreq1, *bfreq0=NULL; // base frequencies
double *ChIPScore; // chip score
int maskR; // mask simple repeats before running the algorithm
// pwms
double ***pwm; // initial population of PWMs from spaced dyads
int *pwmLen; // initial pwm lengths
double **opwm2; // EM-derived PWM
double ***opwm; // observed PWMs from identified sites
double ***epwm; // em-optimized PWMs
double **logepwm; // log(em-optimized PWM)
int *pwmnewLen; // final motif length after extending to both ends
// llr score distr.
Pgfs *llrDist; // llr distribution from pgf method
int llrDim; // llr distribution dimension
int **ipwm; // integer pwm for computing llr score distribution
// EM, motif, sites
double pvalueCutoff; // user input, used to determine score cutoff based on ipwm
int *scoreCutoff; // pwm score cutoff for the corresponding p-value cutoff
double logev; // log of E-value of a motif;
int useChIPscore; // indicator for using ChIP-seq score for seq. selection for EM
int numEM; // number of EM steps
double E_valueCutoff; // log E-value cutoff
//int nsitesEM; // number of binding sites in sequences subjected to EM
int minsitesEM; // minimal number of sites in a motif in EM sequences
int *nsites; // number of binding sites in full data
int minsites; // minimal number of sites in a motif in full data
Sites **site; // binding sites in all sequences
int motifCn; // number of motifs sought and found
int extTrim;
int noMotifFound; // none of the dyads in the population resulted in a motif
char **pwmConsensus; // consensus sequences of motifs
double pwmDistCutoff; // test statistic for motif pwm similarity
char *uniqMotif; // motifs in a population unique or not
int numUniq; // number of unique motifs in a population
int slideWinPWM; // sliding window for comparing pwm similarity
int widthWt; // window width in which nucleotides are given large weights for PWM optimization
int fullScan; // scan scan on the original sequences or masked sequences
// background
int numBackgSets;
// weights
double **posWeight; // spatial weights
int weightType; // four weight types 0, 1, 2, 3, or 4
// words for spaced dyad
Words *word; // top-ranked k-mers as the words for spaced dyads
int numTop3mer,numTop4mer,numTop5mer; // No. of top-ranked k-mers as words for dyads
int maxWordSize; // max of the above three
int numWordGroup; // number of non-zero k-mer groups
int minSpaceWidth,maxSpaceWidth; // min and max width of spacer of the spaced dyads
Chrs **dyad; // initial population of "chromosomes"
char **sdyad; // char of spaced dyads
// GA
int populationSize,numGeneration; // GA parameters
double maxpMutationRate;
Fitness *fitness; // "chromosome" fitness
Wheel *wheel; // roulette-wheel selection
// to speed up only select a subset of sequences for EM algorithm
double fEM; // percentage of sequences used in EM algorithm
int numSeqEM; // number of sequences subject to EM
char *Iseq; // Indicator if a sequence is used in EM or not
int *emSeqLen; // length of sequences used in EM
double *maxpFactor;
int numCycle; // number of GADEM cycles
int generationNoMotif; // maximal number of GA generations in a GADEM cycle resulted in no motifs
// mis.
//seed_t seed; // random seed
int motifCn2,id,numCycleNoMotif,verbose,minminSites,nmotifs;
int startPWMfound,stopCriterion;
char *mFileName,*oFileName,*pwmFileName,*tempRbFileName;
time_t start;
int cn[4],bcn[4],*seqCn,*bseqCn,avebnsites,avebnsiteSeq,totalSitesInput;
int i;
int ii=0;
int jjj=0;
/*************/
FILE * output = fopen("output.txt", "w");
/*************/
GetRNGstate();
mFileName=alloc_char(500); mFileName[0]='\0';
oFileName=alloc_char(500); oFileName[0]='\0';
pwmFileName=alloc_char(500); pwmFileName[0]='\0';
bFileName=alloc_char(500); bFileName[0]='\0';
//tempRbFileName=alloc_char(500); tempRbFileName[0]='\0';
seq=NULL; aveSeqLen=0; maxSeqLen=0;
//minsites=-1;
startPWMfound=0;
maxSeqLen=0;
for(incr=1;incr<longueur;incr=incr+2)
{
if (length(STRING_ELT(sequence,(incr)))>maxSeqLen) maxSeqLen=length(STRING_ELT(sequence,(incr)));
}
// fprintf(output,"maxLength=%d",maxSeqLen);
// exit(0);
seq=alloc_char_char(numSeq,maxSeqLen+1);
for(incr=1;incr<longueur;incr=incr+2)
{
for (int j=0; j<length(STRING_ELT(sequence,(incr))); j++)
{
seq[IncrementTemp][j]=CHAR(STRING_ELT(sequence,(incr)))[j];
}
IncrementTemp++;
}
verbose=LOGICAL_VALUE(Rverbose);
numWordGroup=INTEGER_VALUE(RnumWordGroup);
minsites=INTEGER_VALUE(RminSites);
numTop3mer=INTEGER_VALUE(RnumTop3mer);
numTop4mer=INTEGER_VALUE(RnumTop4mer);
numTop5mer=INTEGER_VALUE(RnumTop5mer);
numGeneration=INTEGER_VALUE(RnumGeneration);
populationSize=INTEGER_VALUE(RpopulationSize);
pvalueCutoff=NUMERIC_VALUE(RpValue);
E_valueCutoff=NUMERIC_VALUE(ReValue);
extTrim=INTEGER_VALUE(RextTrim);
minSpaceWidth=INTEGER_VALUE(RminSpaceWidth);
maxSpaceWidth=INTEGER_VALUE(RmaxSpaceWidth);
useChIPscore=NUMERIC_VALUE(RuseChIPscore);
numEM=INTEGER_VALUE(RnumEM);
fEM=NUMERIC_VALUE(RfEM);
widthWt=INTEGER_VALUE(RwidthWt);
fullScan=INTEGER_VALUE(RfullScan);
slideWinPWM=INTEGER_VALUE(RslideWinPWM);
numUniq=populationSize;
stopCriterion=INTEGER_VALUE(RstopCriterion);
numBackgSets=INTEGER_VALUE(RnumBackgSets);
weightType=NUMERIC_VALUE(RweightType);
//const char *tempRbFileName[1];
tempRbFileName = convertRString2Char(RbFileName);
//tempRbFileName[0]=CHAR(STRING_ELT(RbFileName,0));
nmotifs = INTEGER_VALUE(Rnmotifs);
maskR = INTEGER_VALUE(RmaskR);
if(numSeq>MAX_NUM_SEQ)
{
error("Error: maximal number of seqences reached!\nPlease reset MAX_NUM_SEQ in gadem.h and rebuild (see installation)\n");
}
strcpy(bFileName,tempRbFileName);
ChIPScore=alloc_double(MAX_NUM_SEQ);
seqLen=alloc_int(MAX_NUM_SEQ);
geneID=alloc_int(MAX_NUM_SEQ);
// seq=sequences;
// numSeq=size;
int len;
for (i=0; i<numSeq; i++)
{
len=strlen(seq[i]);
seqLen[i]=len;
geneID[i]=INTEGER(accession)[i];
}
aveSeqLen=0;
for (i=0; i<numSeq; i++) aveSeqLen +=seqLen[i]; aveSeqLen /=(double)numSeq;
for (i=0; i<numSeq; i++) {
if (seqLen[i]>maxSeqLen) maxSeqLen=seqLen[i];
}
rseq=alloc_char_char(numSeq,maxSeqLen+1);
oseq=alloc_char_char(numSeq,maxSeqLen+1);
orseq=alloc_char_char(numSeq,maxSeqLen+1);
for (i=0; i<numSeq; i++)
{
if(seqLen[i]>maxSeqLen) maxSeqLen=seqLen[i];
}
reverse_seq(seq,rseq,numSeq,seqLen);
// make a copy of the original sequences both strands
for (i=0; i<numSeq; i++)
{
for (int j=0; j<seqLen[i]; j++)
{
oseq[i][j]=seq[i][j];
orseq[i][j]=rseq[i][j];
}
oseq[i][seqLen[i]]='\0'; orseq[i][seqLen[i]]='\0';
}
if (strcmp(bFileName,"NULL")!= 0)
{
bfreq0=alloc_double(5);
read_background(bFileName,bfreq0);
}
if (GET_LENGTH(RListPWM)!= 0)
{
startPWMfound=1;
}
else { }
// check for input parameters
if(numGeneration<1)
{
error("number of generaton < 1.\n");
}
if(populationSize<1)
{
error("population size < 1.\n");
}
if (minSpaceWidth<0)
{
error("minimal number of unspecified bases in spaced dyads <0.\n");
}
if (maxSpaceWidth<0)
{
error("maximal number of unspecified bases in spaced dyads <0.\n");
}
if (minSpaceWidth>maxSpaceWidth)
{
error("mingap setting must <= to maxgap setting.\n\n");
}
if (maxSpaceWidth+12>MAX_PWM_LENGTH)
{
error("maxgap setting plus word lengths exceed <MAX_PWM_LENGTH>.\n");
}
if (numEM<0)
{
error("number of EM steps is zero.\n");
}
if (numEM==0)
{
error("number of EM steps = 0, no EM optimization is carried out.\n");
}
if (fullScan!=0 && fullScan!=1)
fullScan=0;
maxWordSize=0;
if (numTop3mer>maxWordSize) maxWordSize=numTop3mer;
if (numTop4mer>maxWordSize) maxWordSize=numTop4mer;
if (numTop5mer>maxWordSize) maxWordSize=numTop5mer;
// any one, two or three: tetramer, pentamer, hexamer
if (numTop3mer==0 && numTop4mer==0 && numTop5mer==0)
{
error("maxw3, maxw4, and maxw5 all zero - no words for spaced dyads.\n");
}
// if (startPWMfound && fEM!=0.5 && fEM!=1.0 & verbose)
// {
// warning("fEM argument is ignored in a seeded analysis\n");
// }
if (startPWMfound)
{
// if(verbose)
// {
// if (populationSize!=10 && populationSize!=100) warning("pop argument is ignored in a seeded analysis, -pop is set to 10.\n");
// if (numGeneration!=1 && numGeneration!=5) warning("gen argument is ignored in a seeded analysis, -gen is set to 1.\n");
// }
fEM=1.0;
populationSize=FIXED_POPULATION; numGeneration=1;
}
// number of sequences for EM
if (fEM>1.0 || fEM<=0.0)
{
error("The fraction of sequences subject to EM is %3.2f.\n",fEM);
}
numSeqEM=(int)(fEM*numSeq);
// memory callocations
Iseq =alloc_char(numSeq+1);
opwm2 =alloc_double_double(MAX_PWM_LENGTH,4);
ipwm =alloc_int_int(MAX_PWM_LENGTH,4);
logepwm=alloc_double_double(MAX_PWM_LENGTH,4);
emSeqLen=alloc_int(numSeqEM);
scoreCutoff=alloc_int(1000);
// scoreCutoff=alloc_int(populationSize);
llrDist=alloc_distr(MAX_DIMENSION);
posWeight=alloc_double_double(numSeq,maxSeqLen);
sseq=alloc_char_char(MAX_NUM_SEQ,maxSeqLen+1);
rsseq=alloc_char_char(MAX_NUM_SEQ,maxSeqLen+1);
bfreq1=base_frequency(numSeq,seq,seqLen);
if (strcmp(bFileName,"NULL") == 0)
{
bfreq0=alloc_double(5);
for (i=0; i<4; i++)
{
bfreq0[i]=bfreq1[i];
}
}
// if minN not specified, set the defaults accordingly
if (minsites==-1)
{
minsites =max(2,(int)(numSeq/20));
}
minsitesEM=(int)(fEM*minsites);
maxpMutationRate=MAXP_MUTATION_RATE;
// determine the distribution and critical cut point
pwmDistCutoff=vector_similarity();
/*---------- select a subset of sequences for EM only --------------*/
if (useChIPscore==1)
{
select_high_scoring_seq_for_EM (ChIPScore,numSeq,numSeqEM,Iseq,fEM);
}
else
{
sample_without_replacement(Iseq,numSeqEM,numSeq);
}
/*-------------------- end of selection --------------------------*/
if (maskR==1) mask_repetitive(geneID,seq,numSeq,seqLen,mFileName);
if (widthWt<20)
{
warning("The window width of sequence centered on the nucleotides having large weights in EM for PWM optimization is small\n Motif longer than %d will not be discovered\n",widthWt);
}
time(&start);
// if (weightType==1 || weightType==3)
//ffprintf(output,fp,"window width of sequence centered on the nucleotides having large weights for PWM optimization: %d\n",widthWt);
//ffprintf(output,fp,"pwm score p-value cutoff for declaring binding site:\t%e\n",pvalueCutoff);
if(verbose)
{
ffprintf(output,output,"==============================================================================================\n");
ffprintf(output,output,"input sequence file: %s\n",mFileName);
fprintf(output,"number of sequences and average length:\t\t\t\t%d %5.1f\n",numSeq,aveSeqLen);
fprintf(output,"Use pgf method to approximate llr null distribution\n");
fprintf(output,"parameters estimated from sequences in: %s\n\n",mFileName);
if (weightType!=0)
fprintf(output,"non-uniform weight applies to each sequence - type:\t\t%d\n",weightType);
fprintf(output,"number of GA generations & population size:\t\t\t%d %d\n\n",numGeneration,populationSize);
fprintf(output,"PWM score p-value cutoff for binding site declaration:\t\t%e\n",pvalueCutoff);
fprintf(output,"ln(E-value) cutoff for motif declaration:\t\t\t%f\n\n",E_valueCutoff);
// fprintf(output,"number (percentage) of sequences selected for EM:\t\t%d(%4.1f\%)\n",numSeqEM,100.0*(double)numSeqEM/(double)numSeq);
fprintf(output,"number of EM steps:\t\t\t\t\t\t%d\n",numEM);
fprintf(output,"minimal no. sites considered for a motif:\t\t\t%d\n\n",minsites);
fprintf(output,"[a,c,g,t] frequencies in input data:\t\t\t\t%f %f %f %f\n",bfreq1[0],bfreq1[1],bfreq1[2],bfreq1[3]);
fprintf(output,"==============================================================================================\n");
}
// if (pgf)
// {
// if (userMarkovOrder!=0 & verbose)
// {
// warning("The user-specified background Markov order (%d) is ignored when -pgf is set to 1\n",userMarkovOrder);
// }
// if (bFileName[0]!='\0' & verbose)
// {
// warning("The user-specified background models: %s are not used when -pgf is set to 1\n",bFileName);
// }
// }
// if (startPWMfound && fEM!=1.0 & verbose)
// {
// warning("fEM argument is ignored in a seeded analysis\n");
// }
// determine seq length by counting only [a,c,g,t], seqLen is used in E-value calculation
// determine the distribution and critical cut point
pwmDistCutoff=vector_similarity();
if (weightType==0) assign_weight_uniform(seqLen,numSeq,posWeight);
else if (weightType==1) assign_weight_triangular(seqLen,numSeq,posWeight);
else if (weightType==2) assign_weight_normal(seqLen,numSeq,posWeight);
else
{
error("Motif prior probability type not found - please choose: 0, 1, or 2\n");
// fprintf(output,"Consider: -posWt 1 for strong central enrichment as in ChIP-seq\n");
// fprintf(output," -posWt 0 for others\n\n");
// exit(0);
}
/* if (startPWMfound) minminSites=minsites;
else minminSites=(int)(0.40*minsitesEM);*/
motifCn=0; noMotifFound=0; numCycle=0; numCycleNoMotif=0;
int compt=0;
int lengthList=GET_LENGTH(RListPWM);
/****************************************/
broadcastOnce(maxSeqLen, numEM, startPWMfound, minminSites, maxpFactor, numSeq, numSeqEM, Iseq, bfreq0, posWeight, weightType, pvalueCutoff, emSeqLen, populationSize);
/****************************************/
do
{
if(!startPWMfound)
{
if(verbose)
{
fprintf(output,"*** Running an unseeded analysis ***\n");
// fprintf(output,"\n|------------------------------------------------------------------|\n");
// fprintf(output,"| |\n");
// fprintf(output,"| *** Running an unseeded analysis *** |\n");
// fprintf(output,"| |\n");
// fprintf(output,"|------------------------------------------------------------------|\n\n");
}
populationSize=INTEGER_VALUE(RpopulationSize);
numGeneration=INTEGER_VALUE(RnumGeneration);
dyad =alloc_chrs(populationSize,4);
wheel =alloc_wheel(populationSize);
fitness=alloc_fitness(populationSize);
maxpFactor=alloc_double(populationSize);
uniqMotif=alloc_char(populationSize+1);
opwm =alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
epwm=alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
pwmConsensus=alloc_char_char(populationSize,MAX_PWM_LENGTH+1);
pwm =alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
pwmLen=alloc_int(populationSize);
sdyad =alloc_char_char(populationSize,MAX_PWM_LENGTH+1);
word =alloc_word(numWordGroup,maxWordSize);
minminSites=(int)(0.40*minsitesEM);
// identify top-ranked k-mers (k=3,4,5) for spaced dyads
if(verbose)
fprintf(output,"GADEM cycle %2d: enumerate and count k-mers... ",numCycle+1);
numWordGroup=word_for_dyad(word,seq,rseq,numSeq,seqLen,bfreq1,&numTop3mer,&numTop4mer,&numTop5mer);
if(verbose)
fprintf(output,"Done.\n");
// generating a "population" of spaced dyads
if(verbose)
fprintf(output,"Initializing GA... ");
initialisation(dyad,populationSize,numWordGroup,word,minSpaceWidth,maxSpaceWidth,maxpFactor);
if(verbose)
fprintf(output,"Done.\n");
}
else
{
if(verbose)
{
fprintf(output,"*** Running an seeded analysis ***\n");
// fprintf(output,"\n|------------------------------------------------------------------|\n");
// fprintf(output,"| |\n");
// fprintf(output,"| *** Running a seeded analysis *** |\n");
// fprintf(output,"| |\n");
// fprintf(output,"|------------------------------------------------------------------|\n\n");
}
populationSize=FIXED_POPULATION;
dyad =alloc_chrs(populationSize,4);
pwm=alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
pwmLen=alloc_int(populationSize);
maxpFactor=alloc_double(populationSize);
uniqMotif=alloc_char(populationSize+1);
opwm =alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
epwm=alloc_double_double_double(populationSize,MAX_PWM_LENGTH,4);
pwmConsensus=alloc_char_char(populationSize,MAX_PWM_LENGTH+1);
sdyad =alloc_char_char(populationSize,MAX_PWM_LENGTH+1);
word =alloc_word(numWordGroup,maxWordSize);
wheel =alloc_wheel(populationSize);
fitness=alloc_fitness(populationSize);
minminSites=minsites;
int lengthMatrix;
lengthMatrix=GET_LENGTH(VECTOR_ELT(RListPWM,compt));
RSpwm=allocMatrix(REALSXP,4,(lengthMatrix/4));
RSpwm=VECTOR_ELT(RListPWM,compt);
pwmLen[0]=read_pwm0(RSpwm,pwm[0],lengthMatrix);
for(i=1; i<populationSize; i++)
{
for (int j=0; j<pwmLen[0]; j++)
{
for (int k=0; k<4; k++)
{
pwm[i][j][k]=pwm[0][j][k];
}
}
pwmLen[i]=pwmLen[0];
}
for (i=0; i<populationSize; i++)
{
maxpFactor[i]=FIXED_MAXPF*(i+1);
standardize_pwm(pwm[i],pwmLen[i]);
consensus_pwm(pwm[i],pwmLen[i],pwmConsensus[i]);
strcpy(sdyad[i],pwmConsensus[i]);
}
}
generationNoMotif=0;
for (jjj=0; jjj<numGeneration; jjj++)
{
// convert spaced dyads to letter probability matrix
if (!startPWMfound)
{
dyad_to_pwm(word,populationSize,dyad,pwm,pwmLen);
}
/*
DO_APPLY(populationCalculation(maxSeqLen, numEM, fitness+ii,
startPWMfound, minminSites, maxpFactor[ii],
numSeq, numSeqEM, seq, rseq, seqLen, Iseq,
bfreq0, posWeight, weightType,
pvalueCutoff, emSeqLen,
pwm[ii], pwmLen[ii], epwm[ii], opwm[ii],
pwmConsensus[ii], scoreCutoff+ii, sdyad[ii], ii),
populationSize, ii);
*/
/* Create the structure to send to all the other slaves */
broadcastEveryCycle(Iseq, pwm, pwmLen, pwmConsensus, scoreCutoff, sdyad, populationSize);
populationCalculation(maxSeqLen, numEM, fitness+ii,
startPWMfound, minminSites, maxpFactor[ii],
numSeq, numSeqEM, seq, rseq, seqLen, Iseq,
bfreq0, posWeight, weightType,
pvalueCutoff, emSeqLen,
pwm[ii], pwmLen[ii], epwm[ii], opwm[ii],
pwmConsensus[ii], scoreCutoff+ii, sdyad[ii], ii);
/* Receive the analyzed data from all the other slaves and compile them */
//getPopCalcResults(...);
// for (i=0; i<5; i++)
// {
// fprintf(output,"fitness.value=%lf\n",fitness[i].value);
// fprintf(output,"fitness.index=%d\n",fitness[i].index);
// fprintf(output,"maxpfactor=%lf\n",maxpFactor[i]);
// fprintf(output,"scoreCutoff=%d\n",scoreCutoff[i]);
// fprintf(output," spacedDyad: %s\n",sdyad[i]);
//
// for (l=0; l<pwmLen[i]; l++)
// {
// for (m=0; m<4; m++)
// {
// fprintf(output,"opwm[%d][%d][%d]=%lf ",i,l,m,opwm[i][l][m]);
// fprintf(output,"epwm[%d][%d][%d]=%lf ",i,l,m,epwm[i][l][m]);
// fprintf(output,"pwm[%d][%d][%d]=%lf ",i,l,m,pwm[i][l][m]);
// }
// fprintf(output,"\n");
// }
// fprintf(output,"\n");
// }
//
// testrand=runif(0,1);
// fprintf(output,"testrand1=%lf\n",testrand);
if (populationSize>1)
{
sort_fitness(fitness,populationSize);
}
// for (i=0; i<5; i++)
// {
// fprintf(output,"fitness.value=%lf\n",fitness[i].value);
// fprintf(output,"fitness.index=%d\n",fitness[i].index);
// }
numUniq=check_pwm_uniqueness_dist(opwm, pwmLen,
populationSize, fitness,
pwmDistCutoff, E_valueCutoff,
uniqMotif, slideWinPWM);
// for (i=0; i<5; i++)
// {
// fprintf(output,"fitness.value=%lf\n",fitness[i].value);
// fprintf(output,"fitness.index=%d\n",fitness[i].index);
// fprintf(output,"maxpfactor=%lf\n",maxpFactor[i]);
// fprintf(output,"scoreCutoff=%d\n",scoreCutoff[i]);
// fprintf(output," spacedDyad: %s\n",sdyad[i]);
//
// for (l=0; l<pwmLen[i]; l++)
// {
// for (m=0; m<4; m++)
// {
// fprintf(output,"opwm[%d][%d][%d]=%lf",i,l,m,opwm[i][l][m]);
// }
// fprintf(output,"\n");
// }
// fprintf(output,"\n");
// }
if(verbose)
{
fprintf(output,"GADEM cycle[%3d] generation[%3d] number of unique motif: %d\n",numCycle+1,jjj+1,numUniq);
for (i=0; i<populationSize; i++)
{
if (uniqMotif[i]=='1')
{
fprintf(output," spacedDyad: %s ",sdyad[fitness[i].index]);
for (int j=strlen(sdyad[fitness[i].index]); j<maxSpaceWidth+10; j++) fprintf(output," ");
fprintf(output,"motifConsensus: %s ",pwmConsensus[fitness[i].index]);
for (int j=strlen(sdyad[fitness[i].index]); j<maxSpaceWidth+10; j++) fprintf(output," ");
fprintf(output," %3.2f fitness: %7.2f\n",maxpFactor[fitness[i].index],fitness[i].value);
}
}
fprintf(output,"\n");
}
if (jjj<numGeneration-1)
{
// fitness based selection with replacement
roulett_wheel_fitness(fitness,populationSize,wheel);
// mutation and crossover operations
if (populationSize>1)
{
testrand=runif(0,1);
if (testrand>=0.5)
{
mutation(dyad,numWordGroup,word,minSpaceWidth,maxSpaceWidth,wheel,populationSize,fitness,uniqMotif,
maxpFactor,maxpMutationRate);
}
else
{
crossover(dyad,numWordGroup,word,minSpaceWidth,maxSpaceWidth,wheel,populationSize,fitness,uniqMotif, maxpFactor,maxpMutationRate);
}
}
else
{
mutation(dyad,numWordGroup,word,minSpaceWidth,maxSpaceWidth,wheel,populationSize,fitness,uniqMotif, maxpFactor,maxpMutationRate);
}
}
}
if((numCycle+1)< lengthList)
{
compt++;
}
else
{
startPWMfound=0;
}
numCycle++;
site=alloc_site_site(numUniq+1,MAX_SITES);
nsites=alloc_int(numUniq+1);
pwmnewLen=alloc_int(numUniq+1); // after base extension and trimming
seqCn=alloc_int(MAX_NUM_SEQ);
bseqCn=alloc_int(MAX_NUM_SEQ);
// final step user-specified background model is used
motifCn2=0; // motifCn per GADEM cycle
for (ii=0; ii<populationSize; ii++)
{
id=fitness[ii].index;
if(uniqMotif[ii]=='0')
{
continue;
}
// approximate the exact llr distribution using Staden's method
// if(verbose)
// {
// fprintf(output,"Approximate the exact pwm llr score distribution using the pgf method.\n");
// }
log_ratio_to_int(epwm[id],ipwm,pwmLen[id],bfreq0);
// compute score distribution of the (int)PWM using Staden's method
llrDim=pwm_score_dist(ipwm,pwmLen[id],llrDist,bfreq0);
//fprintf(output,"Avant ScoreCutoff %d \n",scoreCutoff[id]);
scoreCutoff[id]=determine_cutoff(llrDist,llrDim,pvalueCutoff);
//fprintf(output,"Apres ScoreCutoff %d \n",scoreCutoff[id]);
if(fullScan)
{
nsites[motifCn2]=scan_llr_pgf(llrDist,llrDim,site[motifCn2],numSeq,oseq,orseq,seqLen,ipwm,pwmLen[id],scoreCutoff[id],bfreq0);
}
else
{
nsites[motifCn2]=scan_llr_pgf(llrDist,llrDim,site[motifCn2],numSeq,seq,rseq,seqLen,ipwm,pwmLen[id],scoreCutoff[id],bfreq0);
}
if (nsites[motifCn2]>=max(2,minsites))
{
for (int j=0; j<numSeq; j++) seqCn[j]=0;
for (int j=0; j<nsites[motifCn2]; j++) seqCn[site[motifCn2][j].seq]++;
for (int j=0; j<4; j++) cn[j]=0;
for (int j=0; j<numSeq; j++)
{
if (seqCn[j]==0) cn[0]++;
if (seqCn[j]==1) cn[1]++;
if (seqCn[j]==2) cn[2]++;
if (seqCn[j]>2) cn[3]++;
}
totalSitesInput=nsites[motifCn2];
if (extTrim)
{
if (fullScan)
{
extend_alignment(site[motifCn2],numSeq,oseq,orseq,seqLen,nsites[motifCn2],pwmLen[id],&(pwmnewLen[motifCn2]));
}
else
{
extend_alignment(site[motifCn2],numSeq,seq,rseq,seqLen,nsites[motifCn2],pwmLen[id],&(pwmnewLen[motifCn2]));
}
}
else
{
pwmnewLen[motifCn2]=pwmLen[id];
}
if (fullScan)
{
align_sites_count(site[motifCn2],oseq,orseq,nsites[motifCn2],pwmnewLen[motifCn2],opwm2);
}
else
{
align_sites_count(site[motifCn2],seq,rseq,nsites[motifCn2],pwmnewLen[motifCn2],opwm2);
}
standardize_pwm(opwm2,pwmnewLen[motifCn2]);
logev=E_value(opwm2,nsites[motifCn2],bfreq0,pwmnewLen[motifCn2],numSeq,seqLen);
if (logev<=E_valueCutoff)
{
consensus_pwm(opwm2,pwmnewLen[motifCn2],pwmConsensus[id]);
if (fullScan)
{
SET_VECTOR_ELT(ResultsGadem,increment,print_result_R(site[motifCn2],nsites[motifCn2],numSeq,oseq,orseq,seqLen,logev,opwm2,pwmnewLen[motifCn2],motifCn+1,sdyad[id],pwmConsensus[id],numCycle,pvalueCutoff,maxpFactor[id],geneID));
increment++;
print_motif(site[motifCn2],nsites[motifCn2],oseq,orseq,seqLen,pwmnewLen[motifCn2],motifCn+1,opwm2);
}
else
{
SET_VECTOR_ELT(ResultsGadem,increment,print_result_R(site[motifCn2],nsites[motifCn2],numSeq,seq,rseq,seqLen,logev,opwm2,pwmnewLen[motifCn2],
motifCn+1,sdyad[id],pwmConsensus[id],numCycle,pvalueCutoff,maxpFactor[id],geneID));
increment++;
print_motif(site[motifCn2],nsites[motifCn2],seq,rseq,seqLen,pwmnewLen[motifCn2],motifCn+1,opwm2);
}
mask_sites(nsites[motifCn2],seq,rseq,seqLen,site[motifCn2],pwmnewLen[motifCn2]);
/* ----------------------compute the average number of sites in background sequences ----------------------*/
avebnsites=0; avebnsiteSeq=0;
for (i=0; i<numBackgSets; i++)
{
simulate_background_seq(bfreq0,numSeq,seqLen,sseq);
reverse_seq(sseq,rsseq,numSeq,seqLen);
nsites[motifCn2]=scan_llr_pgf(llrDist,llrDim,site[motifCn2],numSeq,sseq,rsseq,seqLen,ipwm,pwmLen[id],scoreCutoff[id],bfreq0);
for (int j=0; j<numSeq; j++) bseqCn[j]=0;
for (int j=0; j<nsites[motifCn2]; j++) bseqCn[site[motifCn2][j].seq]++;
for (int j=0; j<4; j++) bcn[j]=0;
for (int j=0; j<numSeq; j++)
{
if (bseqCn[j]==0) bcn[0]++;
if (bseqCn[j]==1) bcn[1]++;
if (bseqCn[j]==2) bcn[2]++;
if (bseqCn[j]>2) bcn[3]++;
}
//ffprintf(output,fq,"background set[%2d] Seqs with 0,1,2,>2 sites: %d %d %d %d\n",i+1,bcn[0],bcn[1],bcn[2],bcn[3]);
avebnsites+=nsites[motifCn2]; avebnsiteSeq+=(numSeq-bcn[0]);
}
avebnsites/=numBackgSets; avebnsiteSeq/=numBackgSets;
/* -----------------end compute the average number of sites in background sequences ----------------------*/
motifCn++; motifCn2++;
//if((numCycle+1) > lengthList & fixSeeded)
// {
// numCycleNoMotif=1;
// startPWMfound=1;
// } else {
numCycleNoMotif=0;
// }
}
}
}
/* for (int i=0; i<motifCn2; i++)
{
mask_sites(nsites[i],seq,rseq,seqLen,site[i],pwmnewLen[i]);
} */
if (site[0])
{
free(site[0]);
site[0]=NULL;
}
if (site)
{
free(site);
site=NULL;
}
if (nsites)
{
free(nsites);
nsites=NULL;
}
if (pwmnewLen)
{
free(pwmnewLen);
pwmnewLen=NULL;
}
if (motifCn2==0)
numCycleNoMotif++;
if (motifCn==nmotifs)
{
fprintf(output,"Maximal number of motifs (%d) reached\n",nmotifs);
break;
}
if (numCycleNoMotif==stopCriterion)
noMotifFound=1;
}while (!noMotifFound);
// fclose(fp);
/*if (!startPWMfound) {
if (dyad[0]) { free(dyad[0]); dyad[0]=NULL; }
if (dyad) { free(dyad); dyad=NULL; }
}*/
if (seqLen)
{
free(seqLen);
seqLen=NULL;
}
if (pwm[0][0])
{
free(pwm[0][0]);
pwm[0][0]=NULL;
}
if (pwm[0])
{
free(pwm[0]);
pwm[0]=NULL;
}
if (pwm)
{
free(pwm);
pwm=NULL;
}
if (opwm2[0])
{
free(opwm2[0]);
opwm2[0]=NULL;
}
if (opwm2)
{
free(opwm2);
opwm2=NULL;
}
if (opwm[0][0])
{
free(opwm[0][0]);
opwm[0][0]=NULL;
}
if (opwm[0])
{
free(opwm[0]);
opwm[0]=NULL;
}
if (opwm)
{
free(opwm);
opwm=NULL;
}
if(ipwm[0])
{
free(ipwm[0]);
ipwm[0]=NULL;
}
if (ipwm)
{
free(ipwm);
ipwm=NULL;
}
if (pwmLen)
{
free(pwmLen);
pwmLen=NULL;
}
if (seq[0]) { free(seq[0]); seq[0]=NULL; }
if (seq) { free(seq); seq=NULL; }
// if (rseq[0]) { free(rseq[0]); rseq[0]=NULL; }
// if (rseq) { free(rseq); rseq=NULL; }
// if (oseq[0]) { free(oseq[0]); oseq[0]=NULL; }
// if (oseq) { free(oseq); oseq=NULL; }
// if (orseq[0]) { free(orseq[0]); orseq[0]=NULL; }
// if (orseq) { free(orseq); orseq=NULL; }
if (bfreq1)
{
free(bfreq1);
bfreq1=NULL;
}
if (bfreq0)
{
free(bfreq0);
bfreq0=NULL;
}
if (wheel)
{
free(wheel);
wheel=NULL;
}
if (fitness)
{
free(fitness);
fitness=NULL;
}
if (mFileName)
{
free(mFileName);
mFileName=NULL;
}
if (oFileName)
{
free(oFileName);
oFileName=NULL;
}
if (pwmFileName)
{
free(pwmFileName);
pwmFileName=NULL;
}
if (sdyad[0])
{
free(sdyad[0]);
sdyad[0]=NULL;
}
if (sdyad)
{
free(sdyad);
sdyad=NULL;
}
if (pwmConsensus[0])
{
free(pwmConsensus[0]);
pwmConsensus[0]=NULL;
}
if (pwmConsensus)
{
free(pwmConsensus);
pwmConsensus=NULL;
}
//if (!startPWMfound && word) destroy_word(word,numWordGroup);
PutRNGstate();
UNPROTECT(1);
return(ResultsGadem);
}
//This function will calculate the Jocobian for the errors
SEXP jacobian_(SEXP X, SEXP n, SEXP p, SEXP theta, SEXP neurons,SEXP J, SEXP reqCores)
{
int i,j,k;
double z,dtansig;
double *pX;
double *ptheta;
double *pJ;
int rows, columns, nneurons;
SEXP list;
rows=INTEGER_VALUE(n);
columns=INTEGER_VALUE(p);
nneurons=INTEGER_VALUE(neurons);
PROTECT(X=AS_NUMERIC(X));
pX=NUMERIC_POINTER(X);
PROTECT(theta=AS_NUMERIC(theta));
ptheta=NUMERIC_POINTER(theta);
PROTECT(J=AS_NUMERIC(J));
pJ=NUMERIC_POINTER(J);
for(i=0; i<rows; i++)
{
//Rprintf("i=%d\n",i);
for(k=0; k<nneurons; k++)
{
z=0;
for(j=0;j<columns;j++)
{
z+=pX[i+(j*rows)]*ptheta[(columns+2)*k+j+2];
}
z+=ptheta[(columns+2)*k+1];
dtansig=pow(sech(z),2.0);
/*
Derivative with respect to the weight
*/
pJ[i+(((columns+2)*k)*rows)]=-tansig(z);
/*
Derivative with respect to the bias
*/
pJ[i+(((columns+2)*k+1)*rows)]=-ptheta[(columns+2)*k]*dtansig;
/*
Derivate with respect to the betas
*/
for(j=0; j<columns;j++)
{
pJ[i+(((columns+2)*k+j+2)*rows)]=-ptheta[(columns+2)*k]*dtansig*pX[i+(j*rows)];
}
}
}
PROTECT(list=allocVector(VECSXP,1));
SET_VECTOR_ELT(list,0,J);
UNPROTECT(4);
return(list);
}
/*!
\author Hanne Rognebakke
\brief Makes a struct of type containing
Makes a struct of type Data_orig (see caa.h for definition)
Space allocated in this routine is reallocated in re_makedata_COST
*/
int makedata_COST(SEXP i_COSTList, Data_orig **o_D_orig, Data_COST **o_D_COST)
{
Data_orig *D_orig;
Data_COST *D_COST;
Data_obs *D_obs;
Data_mland *D_mland;
int i,f,h,n,s,t;
int l_int,n_trip,n_fish,N_int,nHaul,nSize;
int ind,ind_alk,ind_fish,ind_fish_l,ind_haul,ind_size,ind_orig,ind_t;
long *lengths;
double l;
double *P_l,*int_len;
SEXP elmt = R_NilValue;
FILE *caa_debug;
#ifdef DEBUG_COST
caa_debug = fopen("caa_debug_COST.txt","w");
#endif
/* Allocating space for COST object */
D_COST = CALLOC(1,Data_COST);
/* Observer data */
D_obs = CALLOC(1,Data_obs);
if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_trip_obs")))
D_obs->n_trip = INTEGER_VALUE(elmt); // number of trips with observer data
if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_trip_obs")))
D_obs->num_trip = INTEGER_POINTER(AS_INTEGER(elmt)); // number of hauls pr trip
if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_haul_disc")))
D_obs->num_haul_disc = INTEGER_POINTER(AS_INTEGER(elmt)); // number of length-measured discarded fish pr haul
if(!Rf_isNull(elmt = getListElement(i_COSTList, "season_obs")))
D_obs->season = INTEGER_POINTER(AS_INTEGER(elmt)); // observed month
if(!Rf_isNull(elmt = getListElement(i_COSTList, "l_disc")))
D_obs->l_disc = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length categories for discard samples
if(!Rf_isNull(elmt = getListElement(i_COSTList, "lfreq_disc")))
D_obs->lfreq_disc = INTEGER_POINTER(AS_INTEGER(elmt)); // number at length for discards
if(!Rf_isNull(elmt = getListElement(i_COSTList, "haulsize_disc")))
D_obs->haulsize_disc = NUMERIC_POINTER(AS_NUMERIC(elmt)); // number of discards in haul
if(!Rf_isNull(elmt = getListElement(i_COSTList, "sampsize_disc")))
D_obs->sampsize_disc = NUMERIC_POINTER(AS_NUMERIC(elmt)); // number of discards sampled
if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_alk_disc")))
D_obs->num_alk = INTEGER_POINTER(AS_INTEGER(elmt)); // number of discard age-length data within trip
if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_l_disc")))
D_obs->alk_l = NUMERIC_POINTER(AS_NUMERIC(elmt)); // lengths for discard age-length data
if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_a_disc")))
D_obs->alk_a = INTEGER_POINTER(AS_INTEGER(elmt)); // ages for discard age-length data
if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_lfreq_disc")))
D_obs->alk_lfreq = INTEGER_POINTER(AS_INTEGER(elmt)); // numbers at length for discard age-length data
if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_trip_land")))
D_obs->num_trip_land = INTEGER_POINTER(AS_INTEGER(elmt)); // number of size classes pr trip with landings
if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_size_land")))
D_obs->num_size_land = INTEGER_POINTER(AS_INTEGER(elmt)); // number of measured landed fish pr size class
if(!Rf_isNull(elmt = getListElement(i_COSTList, "l_land")))
D_obs->l_land = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length categories for landing samples
if(!Rf_isNull(elmt = getListElement(i_COSTList, "lfreq_land")))
D_obs->lfreq_land = INTEGER_POINTER(AS_INTEGER(elmt)); // number at length for landings
if(!Rf_isNull(elmt = getListElement(i_COSTList, "totsize_land")))
D_obs->totsize_land = NUMERIC_POINTER(AS_NUMERIC(elmt)); // total weight landed in size class
if(!Rf_isNull(elmt = getListElement(i_COSTList, "sampsize_land")))
D_obs->sampsize_land = NUMERIC_POINTER(AS_NUMERIC(elmt)); // weight of landings sampled for lengths in size class
/* Market landing data */
D_mland = CALLOC(1,Data_mland);
if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_trip_mland")))
D_mland->n_trip = INTEGER_VALUE(elmt); // number of trips with market landing data
if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_trip_mland")))
D_mland->num_trip = INTEGER_POINTER(AS_INTEGER(elmt)); // number of size classes pr trip with market landings
if(!Rf_isNull(elmt = getListElement(i_COSTList, "season_mland")))
D_mland->season = INTEGER_POINTER(AS_INTEGER(elmt)); // observed month
if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_alk_mland")))
D_mland->num_alk = INTEGER_POINTER(AS_INTEGER(elmt)); // number of market landing age-length data within trip
if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_l_mland")))
D_mland->alk_l = NUMERIC_POINTER(AS_NUMERIC(elmt)); // lengths for market landing age-length data
if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_a_mland")))
D_mland->alk_a = INTEGER_POINTER(AS_INTEGER(elmt)); // ages for market landing age-length data
if(!Rf_isNull(elmt = getListElement(i_COSTList, "alk_lfreq_mland")))
D_mland->alk_lfreq = INTEGER_POINTER(AS_INTEGER(elmt)); // numbers at length for market landing age-length data
if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_size_mland")))
D_mland->num_size = INTEGER_POINTER(AS_INTEGER(elmt)); // number of measured market landing fish pr size class
if(!Rf_isNull(elmt = getListElement(i_COSTList, "l_mland")))
D_mland->l = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length categories for market landing samples
if(!Rf_isNull(elmt = getListElement(i_COSTList, "lfreq_mland")))
D_mland->lfreq = INTEGER_POINTER(AS_INTEGER(elmt)); // number at length for market landings
if(!Rf_isNull(elmt = getListElement(i_COSTList, "totsize_mland")))
D_mland->totsize = NUMERIC_POINTER(AS_NUMERIC(elmt)); // total weight for market landing in size class
if(!Rf_isNull(elmt = getListElement(i_COSTList, "sampsize_mland")))
D_mland->sampsize = NUMERIC_POINTER(AS_NUMERIC(elmt)); // weight of market landings sampled for lengths in size class
/* Allocating space for censoring parameters */
D_COST->cens = CALLOC(1,cens_struct);
D_COST->cens->ncat = D_obs->n_trip+D_mland->n_trip;
D_COST->cens->r = CALLOC(D_COST->cens->ncat,double);
D_COST->cens->mu = CALLOC(3,double);
D_COST->cens->tau = CALLOC(3,double);
/* Allocating space for 'original' parameters */
if(!Rf_isNull(elmt = getListElement(i_COSTList, "num_fish")))
n_fish = INTEGER_VALUE(elmt);
n_trip = D_obs->n_trip+D_mland->n_trip;
D_orig = CALLOC(1,Data_orig);
D_orig->nFishBoat = CALLOC(n_trip,int); // Free ok
D_orig->totage = CALLOC(n_fish,int); // Free ok
D_orig->totlength = CALLOC(n_fish,double); // Free ok
D_orig->replength = CALLOC(n_fish,int); // Free ok
D_orig->discard = CALLOC(n_fish,int); // Free ok
D_orig->landed = CALLOC(n_fish,int); // Free ok
D_orig->start_noAge = CALLOC(n_trip,int); // Free ok
D_orig->start_Age = CALLOC(n_trip,int); // Free ok
D_orig->num_noAge = CALLOC(n_trip,int); // Free ok
D_orig->haulweight = CALLOC(n_trip,double); // Free ok
D_orig->season = CALLOC(n_trip,int); // Free ok
D_orig->n_discard = CALLOC(n_trip,int); // Free ok
D_orig->n_landed = CALLOC(n_trip,int); // Free ok
if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_int_len")))
D_orig->n_int_len = INTEGER_VALUE(elmt); // number of intervals for length
N_int = D_orig->n_int_len;
if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_lim")))
D_orig->int_len_lim = NUMERIC_POINTER(AS_NUMERIC(elmt)); // lower limits of length-intervals
if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_vec")))
D_orig->int_len = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length value for intervals
lengths = CALLOC(N_int,long); // Free ok
P_l = CALLOC(N_int,double); // Free ok
//printf("\nStart simulate total lengths for observer data\n");
/* Simulate total lengths for observer data */
ind_fish = 0;
ind_fish_l = 0;
ind_haul = 0;
ind_size = 0;
ind_alk = 0;
ind_orig = 0;
ind = 0;
for(t=0;t<D_obs->n_trip;t++)
{
/* Discard data */
D_orig->start_noAge[t] = ind_orig + D_obs->num_alk[t];
D_orig->start_Age[t] = ind_orig;
D_orig->num_noAge[t] = N_int;
D_orig->nFishBoat[t] = D_obs->num_alk[t]+N_int;
D_orig->season[t] = D_obs->season[t];
D_orig->n_discard[t] = 0;
D_orig->n_landed[t] = 0;
ind_orig = D_orig->start_noAge[t];
for(f=0;f<N_int;f++)
{
D_orig->totage[ind_orig] = -99999;
D_orig->totlength[ind_orig] = D_orig->int_len[f];
D_orig->replength[ind_orig] = 0;
D_orig->discard[ind_orig] = 0;
D_orig->landed[ind_orig] = 0;
ind_orig++;
}
ind_orig = D_orig->start_noAge[t];
for(h=0;h<D_obs->num_trip[t];h++)
{
if(D_obs->num_haul_disc[ind_haul]>0)
{
nHaul = 0;
for(i=0;i<N_int;i++)
P_l[i] = 0.0;
for(f=0;f<D_obs->num_haul_disc[ind_haul];f++)
{
l = D_obs->l_disc[ind_fish];
l_int = 0;
while(l > D_orig->int_len_lim[l_int])
l_int++;
P_l[l_int] += D_obs->lfreq_disc[ind_fish];
D_orig->replength[ind_orig+l_int] += D_obs->lfreq_disc[ind_fish];
D_orig->discard[ind_orig+l_int] += D_obs->lfreq_disc[ind_fish];
D_orig->n_discard[t] += D_obs->lfreq_disc[ind_fish];
nHaul += D_obs->lfreq_disc[ind_fish];
ind_fish++;
}
// convert to probabilities
for(i=0;i<N_int;i++)
P_l[i] /= nHaul;
// number of fish to be simulated
if(nHaul==0)
n=0;
else
n = (int) nHaul*(D_obs->haulsize_disc[ind_haul]/D_obs->sampsize_disc[ind_haul]-1);
my_genmul(n,P_l,N_int,lengths);
for(i=0;i<N_int;i++)
{
D_orig->replength[ind_orig+i] += (int) lengths[i];
D_orig->discard[ind_orig+i] += (int) lengths[i];
D_orig->n_discard[t] += (int) lengths[i];
}
}
ind_haul++;
}
// put the age-length data into D_orig object
for(f=0;f<D_obs->num_alk[t];f++)
{
D_orig->totage[ind] = D_obs->alk_a[ind_alk];
D_orig->totlength[ind] = D_obs->alk_l[ind_alk];
D_orig->replength[ind] = D_obs->alk_lfreq[ind_alk];
D_orig->discard[ind] = D_obs->alk_lfreq[ind_alk];
// remove length count for lengths with missing ages
l_int = 0;
while(D_obs->alk_l[ind_alk] > D_orig->int_len_lim[l_int])
l_int++;
D_orig->replength[ind_orig+l_int] -= D_obs->alk_lfreq[ind_alk];
D_orig->discard[ind_orig+l_int] -= D_obs->alk_lfreq[ind_alk];
if(D_orig->replength[ind_orig+l_int]<0)
{
printf("trip=%d,ind_alk=%d,ind_orig=%d,replength=%d\n",
t,ind_alk,ind_orig+l_int,D_orig->replength[ind_orig+l_int]);
write_warning("makedata_COST:Something is wrong\n");
write_warning("age-length data not in length-only data\n");
D_orig->replength[ind_orig+l_int] = 0;
D_orig->discard[ind_orig+l_int] = 0;
D_orig->n_discard[t] = 0;
}
ind_alk++;
ind++;
}
ind += N_int;
/* Landing data */
for(s=0;s<D_obs->num_trip_land[t];s++)
{
// if(D_obs->num_size_land[ind_size]==0)
nSize = 0;
for(i=0;i<N_int;i++)
P_l[i] = 0.0;
for(f=0;f<D_obs->num_size_land[ind_size];f++)
{
l = D_obs->l_land[ind_fish_l];
l_int = 0;
while(l > D_orig->int_len_lim[l_int])
l_int++;
P_l[l_int] += D_obs->lfreq_land[ind_fish_l];
D_orig->replength[ind_orig+l_int] += D_obs->lfreq_land[ind_fish_l];
D_orig->landed[ind_orig+l_int] += D_obs->lfreq_land[ind_fish_l];
D_orig->n_landed[t] += D_obs->lfreq_land[ind_fish_l];
nSize += D_obs->lfreq_land[ind_fish_l];
ind_fish_l++;
}
// convert to probabilities
for(i=0;i<N_int;i++)
P_l[i] /= nSize;
// number of fish to be simulated
n = nSize*(D_obs->totsize_land[ind_size]/D_obs->sampsize_land[ind_size]-1);
my_genmul(n,P_l,N_int,lengths);
for(i=0;i<N_int;i++)
{
D_orig->replength[ind_orig+i] += (int) lengths[i];
D_orig->landed[ind_orig+i] += (int) lengths[i];
D_orig->n_landed[t] += (int) lengths[i];
}
ind_size++;
}
ind_orig += N_int;
}
#ifdef DEBUG_COST
n=0;
for(t=0;t<D_obs->n_trip;t++)
{
fprintf(caa_debug,"t=%d,nFishBoat=%d,start_noAge=%d,num_noAge=%d\n",
t,D_orig->nFishBoat[t],D_orig->start_noAge[t],D_orig->num_noAge[t]);
n += D_orig->nFishBoat[t];
}
fprintf(caa_debug,"n=%d,totage[i],totlength[i],replength[i]:\n",n);
n=0;
for(i=0;i<n_fish;i++)
{
fprintf(caa_debug,"i=%d,%d,%f,%d\n",i,D_orig->totage[i],
exp(D_orig->totlength[i]),D_orig->replength[i]);
n += D_orig->replength[i];
}
fprintf(caa_debug,"n=%d\n",n);
#endif
//printf("\nStart simulate total lengths for market landing data\n");
ind_fish = 0;
ind_size = 0;
ind_alk = 0;
ind_t = D_obs->n_trip;
for(t=0;t<D_mland->n_trip;t++)
{
D_orig->start_noAge[ind_t] = ind_orig + D_mland->num_alk[t];
D_orig->start_Age[ind_t] = ind_orig;
D_orig->num_noAge[ind_t] = N_int;
D_orig->nFishBoat[ind_t] = D_mland->num_alk[t]+N_int;
D_orig->season[ind_t] = D_mland->season[t];
D_orig->n_discard[ind_t] = 0;
D_orig->n_landed[ind_t] = 0;
ind_orig = D_orig->start_noAge[ind_t];
for(f=0;f<N_int;f++)
{
D_orig->totage[ind_orig] = -99999;
D_orig->totlength[ind_orig] = D_orig->int_len[f];
D_orig->replength[ind_orig] = 0;
D_orig->discard[ind_orig] = 0;
D_orig->landed[ind_orig] = 0;
ind_orig++;
}
ind_orig = D_orig->start_noAge[ind_t];
for(s=0;s<D_mland->num_trip[t];s++)
{
nSize = 0;
for(i=0;i<N_int;i++)
P_l[i] = 0.0;
for(f=0;f<D_mland->num_size[ind_size];f++)
{
l = D_mland->l[ind_fish];
l_int = 0;
while(l > D_orig->int_len_lim[l_int])
l_int++;
P_l[l_int] += D_mland->lfreq[ind_fish];
D_orig->replength[ind_orig+l_int] += D_mland->lfreq[ind_fish];
D_orig->landed[ind_orig+l_int] += D_mland->lfreq[ind_fish];
D_orig->n_landed[ind_t] += D_mland->lfreq[ind_fish];
nSize += D_mland->lfreq[ind_fish];
ind_fish++;
}
// convert to probabilities
for(i=0;i<N_int;i++)
P_l[i] /= nSize;
// number of fish to be simulated
n = nSize*(D_mland->totsize[ind_size]/D_mland->sampsize[ind_size]-1);
my_genmul(n,P_l,N_int,lengths);
for(i=0;i<N_int;i++)
{
D_orig->replength[ind_orig+i] += (int) lengths[i];
D_orig->landed[ind_orig+i] += (int) lengths[i];
D_orig->n_landed[ind_t] += (int) lengths[i];
}
ind_size++;
}
// put the age-length data into D_orig object
for(f=0;f<D_mland->num_alk[t];f++)
{
D_orig->totage[ind] = D_mland->alk_a[ind_alk];
D_orig->totlength[ind] = D_mland->alk_l[ind_alk];
D_orig->replength[ind] = D_mland->alk_lfreq[ind_alk];
D_orig->landed[ind] = D_mland->alk_lfreq[ind_alk];
// remove length count for lengths with missing ages
l_int = 0;
while(D_mland->alk_l[ind_alk] > D_orig->int_len_lim[l_int])
l_int++;
D_orig->replength[ind_orig+l_int] -= D_mland->alk_lfreq[ind_alk];
D_orig->landed[ind_orig+l_int] -= D_mland->alk_lfreq[ind_alk];
if(D_orig->replength[ind_orig+l_int]<0)
{
printf("trip=%d,ind_alk=%d,ind_orig=%d,replength=%d\n",
t,ind_alk,ind_orig+l_int,D_orig->replength[ind_orig+l_int]);
write_warning("makedata_COST:Something is wrong\n");
write_warning("age-length data not in length-only data\n");
D_orig->replength[ind_orig+l_int] = 0;
D_orig->landed[ind_orig+l_int] = 0;
D_orig->n_landed[ind_t] = 0;
}
ind_alk++;
ind++;
}
ind += N_int;
ind_orig += N_int;
ind_t++;
}
printf("\n");
/* Allocating space and initalize simulated discards for market landing data */
if(!Rf_isNull(elmt = getListElement(i_COSTList, "n_int_len_disc")))
N_int = INTEGER_VALUE(elmt); // number of intervals for length
if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_vec_disc")))
int_len = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length value for intervals
if(!Rf_isNull(elmt = getListElement(i_COSTList, "int_len_lim_disc")))
D_mland->int_len_lim = NUMERIC_POINTER(AS_NUMERIC(elmt)); // length value for intervals
n_fish = (N_int)*D_mland->n_trip;
D_mland->N_int_disc = N_int;
D_mland->l_disc = CALLOC(n_fish,double); //Free ok
D_mland->lfreq_disc = CALLOC(n_fish,int); //Free ok
ind = 0;
for(t=0;t<D_mland->n_trip;t++)
{
for(f=0;f<N_int;f++)
{
D_mland->l_disc[ind] = int_len[f];
D_mland->lfreq_disc[ind] = 0;
ind++;
}
}
D_mland->lambda = CALLOC(D_mland->n_trip,double); //Free ok
#ifdef DEBUG_COST
fclose(caa_debug);
#endif
FREE(lengths);
FREE(P_l);
D_COST->obs = D_obs;
D_COST->mland = D_mland;
*o_D_orig = D_orig;
*o_D_COST = D_COST;
return(0);
} /* end of makedata_COST */
SEXP smagmaCholeskyFinal_m(SEXP A, SEXP n, SEXP NB, SEXP zeroTri, SEXP ngpu, SEXP lowerTri)
{
magma_init();
int ndevices;
ndevices = INTEGER_VALUE(ngpu);
int idevice;
for(idevice=0; idevice < ndevices; idevice++)
{
magma_setdevice(idevice);
if(CUBLAS_STATUS_SUCCESS != cublasInit())
{
printf("Error: gpu %d: cublasInit failed\n", idevice);
magma_finalize();
exit(-1);
}
}
// magma_print_devices();
int In, INB;
In = INTEGER_VALUE(n);
INB = INTEGER_VALUE(NB);
double *PA = NUMERIC_POINTER(A);
float *sPA = calloc(In*In, sizeof(float));
int i,j;
for(i = 0; i < In; i++)
{
for(j = 0; j < In; j++)
{
sPA[i*In + j] = (float) PA[i*In + j];
}
}
magma_int_t N, status, info, nGPUs;
N = In;
status = 0;
nGPUs = ndevices;
//INB = magma_get_dpotrf_nb(N);
// INB = 224;
// printf("INB = %d\n", INB);
//ngpu = ndevices;
// printf("ngpu = %d\n", ngpu);
//max_size = INB*(1+N/(INB*ndevices))*INB*((N+INB-1)/INB);
// printf("max_size = %d\n", max_size);
//int imax_size = max_size;
//double *dA;
//magma_dmalloc_pinned((void**)&dA, In*In*sizeof(double));
//ldda = (1+N/(INB*ndevices))*INB;
// printf("ldda = %d\n", ldda);
//magma_dsetmatrix_1D_row_bcyclic(N, N, PA, N, dA, ldda, ngpu, INB);
//magma_dpotrf_mgpu(ngpu, MagmaLower, N, dA, ldda, &info);
int lTri;
lTri = INTEGER_VALUE(lowerTri);
if(lTri)
magma_spotrf_m(nGPUs, MagmaLower, N, sPA, N, &info);
else
magma_spotrf_m(nGPUs, MagmaUpper, N, sPA, N, &info);
if(info != 0)
{
printf("magma_spotrf returned error %d: %s.\n", (int) info, magma_strerror(info));
}
//magma_dgetmatrix_1D_row_bcyclic(N, N, dA, ldda, PA, N, ngpu, INB);
//for(dev = 0; dev < ndevices; dev++)
//{
//magma_setdevice(dev);
//cudaFree(dA[dev]);
//}
magma_finalize();
cublasShutdown();
//caste sPA back to double and set upper or lower triangle to zero if necessary:
int IZeroTri = INTEGER_VALUE(zeroTri);
int zeroUTri = IZeroTri & lTri;
int zeroLTri = IZeroTri & !lTri;
if(!IZeroTri) {
for(i = 1; i< In; i++) {
for(j=1; j < In; j++) {
PA[i*In + j] = (double) sPA[i*In + j];
}
}
} else if(zeroUTri) {
for(i = 1; i< In; i++) {
for(j=1; j < In; j++) {
if(i > j)
PA[i*In + j] = 0;
else
PA[i*In + j] = (double) sPA[i*In + j];
}
}
} else {
for(i = 1; i< In; i++) {
for(j=1; j < In; j++) {
if(i < j)
PA[i*In + j] = 0;
else
PA[i*In + j] = (double) sPA[i*In + j];
}
}
}
UNPROTECT(1);
free(sPA);
return(R_NilValue);
}
SEXP digest(SEXP Txt, SEXP Algo, SEXP Length, SEXP Skip, SEXP Leave_raw) {
FILE *fp=0;
char *txt;
int algo = INTEGER_VALUE(Algo);
int length = INTEGER_VALUE(Length);
int skip = INTEGER_VALUE(Skip);
int leaveRaw = INTEGER_VALUE(Leave_raw);
SEXP result = NULL;
char output[128+1], *outputp = output; /* 33 for md5, 41 for sha1, 65 for sha256, 128 for sha512; plus trailing NULL */
int nChar;
int output_length = -1;
if (IS_RAW(Txt)) { /* Txt is either RAW */
txt = (char*) RAW(Txt);
nChar = LENGTH(Txt);
} else { /* or a string */
txt = (char*) STRING_VALUE(Txt);
nChar = strlen(txt);
}
if (skip>0) {
if (skip>=nChar) nChar=0;
else {
nChar -= skip;
txt += skip;
}
}
if (length>=0 && length<nChar) nChar = length;
switch (algo) {
case 1: { /* md5 case */
md5_context ctx;
output_length = 16;
unsigned char md5sum[16];
int j;
md5_starts( &ctx );
md5_update( &ctx, (uint8 *) txt, nChar);
md5_finish( &ctx, md5sum );
memcpy(output, md5sum, 16);
if (!leaveRaw)
for(j = 0; j < 16; j++)
sprintf(output + j * 2, "%02x", md5sum[j]);
break;
}
case 2: { /* sha1 case */
int j;
sha1_context ctx;
output_length = 20;
unsigned char sha1sum[20];
sha1_starts( &ctx );
sha1_update( &ctx, (uint8 *) txt, nChar);
sha1_finish( &ctx, sha1sum );
memcpy(output, sha1sum, 20);
if (!leaveRaw)
for( j = 0; j < 20; j++ )
sprintf( output + j * 2, "%02x", sha1sum[j] );
break;
}
case 3: { /* crc32 case */
unsigned long val, l;
l = nChar;
val = digest_crc32(0L, 0, 0);
val = digest_crc32(val, (unsigned char*) txt, (unsigned) l);
sprintf(output, "%2.2x", (unsigned int) val);
break;
}
case 4: { /* sha256 case */
int j;
sha256_context ctx;
output_length = 32;
unsigned char sha256sum[32];
sha256_starts( &ctx );
sha256_update( &ctx, (uint8 *) txt, nChar);
sha256_finish( &ctx, sha256sum );
memcpy(output, sha256sum, 32);
if(!leaveRaw)
for( j = 0; j < 32; j++ )
sprintf( output + j * 2, "%02x", sha256sum[j] );
break;
}
case 5: { /* sha2-512 case */
int j;
SHA512_CTX ctx;
output_length = SHA512_DIGEST_LENGTH;
uint8_t sha512sum[output_length], *d = sha512sum;
SHA512_Init(&ctx);
SHA512_Update(&ctx, (uint8 *) txt, nChar);
// Calling SHA512_Final, because SHA512_End will already
// convert the hash to a string, and we also want RAW
SHA512_Final(sha512sum, &ctx);
memcpy(output, sha512sum, output_length);
// adapted from SHA512_End
if(!leaveRaw) {
for (j = 0; j < output_length; j++) {
*outputp++ = sha2_hex_digits[(*d & 0xf0) >> 4];
*outputp++ = sha2_hex_digits[*d & 0x0f];
d++;
}
*outputp = (char)0;
}
break;
}
case 101: { /* md5 file case */
int j;
md5_context ctx;
output_length = 16;
unsigned char buf[1024];
unsigned char md5sum[16];
if (!(fp = fopen(txt,"rb"))) {
error("Cannot open input file: %s", txt);
return(NULL);
}
if (skip > 0) fseek(fp, skip, SEEK_SET);
md5_starts( &ctx );
if (length>=0) {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0
&& length>0) {
if (nChar>length) nChar=length;
md5_update( &ctx, buf, nChar );
length -= nChar;
}
} else {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0)
md5_update( &ctx, buf, nChar );
}
fclose(fp);
md5_finish( &ctx, md5sum );
memcpy(output, md5sum, 16);
if (!leaveRaw)
for(j = 0; j < 16; j++)
sprintf(output + j * 2, "%02x", md5sum[j]);
break;
}
case 102: { /* sha1 file case */
int j;
sha1_context ctx;
output_length = 20;
unsigned char buf[1024];
unsigned char sha1sum[20];
if (!(fp = fopen(txt,"rb"))) {
error("Cannot open input file: %s", txt);
return(NULL);
}
if (skip > 0) fseek(fp, skip, SEEK_SET);
sha1_starts ( &ctx );
if (length>=0) {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0
&& length>0) {
if (nChar>length) nChar=length;
sha1_update( &ctx, buf, nChar );
length -= nChar;
}
} else {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0)
sha1_update( &ctx, buf, nChar );
}
fclose(fp);
sha1_finish ( &ctx, sha1sum );
memcpy(output, sha1sum, 20);
if(!leaveRaw)
for( j = 0; j < 20; j++ )
sprintf( output + j * 2, "%02x", sha1sum[j] );
break;
}
case 103: { /* crc32 file case */
unsigned char buf[1024];
unsigned long val;
if (!(fp = fopen(txt,"rb"))) {
error("Cannot open input file: %s", txt);
return(NULL);
}
if (skip > 0) fseek(fp, skip, SEEK_SET);
val = digest_crc32(0L, 0, 0);
if (length>=0) {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0
&& length>0) {
if (nChar>length) nChar=length;
val = digest_crc32(val , buf, (unsigned) nChar);
length -= nChar;
}
} else {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0)
val = digest_crc32(val , buf, (unsigned) nChar);
}
fclose(fp);
sprintf(output, "%2.2x", (unsigned int) val);
break;
}
case 104: { /* sha256 file case */
int j;
sha256_context ctx;
output_length = 32;
unsigned char buf[1024];
unsigned char sha256sum[32];
if (!(fp = fopen(txt,"rb"))) {
error("Cannot open input file: %s", txt);
return(NULL);
}
if (skip > 0) fseek(fp, skip, SEEK_SET);
sha256_starts ( &ctx );
if (length>=0) {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0
&& length>0) {
if (nChar>length) nChar=length;
sha256_update( &ctx, buf, nChar );
length -= nChar;
}
} else {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0)
sha256_update( &ctx, buf, nChar );
}
fclose(fp);
sha256_finish ( &ctx, sha256sum );
memcpy(output, sha256sum, 32);
if(!leaveRaw)
for( j = 0; j < 32; j++ )
sprintf( output + j * 2, "%02x", sha256sum[j] );
break;
}
case 105: { /* sha2-512 file case */
int j;
SHA512_CTX ctx;
output_length = SHA512_DIGEST_LENGTH;
uint8_t sha512sum[output_length], *d = sha512sum;
unsigned char buf[1024];
if (!(fp = fopen(txt,"rb"))) {
error("Cannot open input file: %s", txt);
return(NULL);
}
if (skip > 0) fseek(fp, skip, SEEK_SET);
SHA512_Init(&ctx);
if (length>=0) {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0
&& length>0) {
if (nChar>length) nChar=length;
SHA512_Update( &ctx, buf, nChar );
length -= nChar;
}
} else {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0)
SHA512_Update( &ctx, buf, nChar );
}
fclose(fp);
// Calling SHA512_Final, because SHA512_End will already
// convert the hash to a string, and we also want RAW
SHA512_Final(sha512sum, &ctx);
memcpy(output, sha512sum, output_length);
// adapted from SHA512_End
if(!leaveRaw) {
for (j = 0; j < output_length; j++) {
*outputp++ = sha2_hex_digits[(*d & 0xf0) >> 4];
*outputp++ = sha2_hex_digits[*d & 0x0f];
d++;
}
*outputp = (char)0;
}
break;
}
default: {
error("Unsupported algorithm code");
return(NULL);
}
}
if (leaveRaw && output_length > 0) {
PROTECT(result=allocVector(RAWSXP, output_length));
memcpy(RAW(result), output, output_length);
} else {
PROTECT(result=allocVector(STRSXP, 1));
SET_STRING_ELT(result, 0, mkChar(output));
}
UNPROTECT(1);
return result;
}
int __cdecl matrix_set_item(LIBXW_MANAGED_MATRIX matrix, LIBXW_VALUE_TYPE value_type, void * value_ptr, int value_len,
int column, int row){
#else
int matrix_set_item(LIBXW_MANAGED_MATRIX matrix, LIBXW_VALUE_TYPE value_type, void * value_ptr, int value_len,
int column, int row){
#endif
LIBXW_DATANODE *headnode = NULL, *newnode = NULL, *prev_ptr = NULL, *cur_ptr = NULL, *flag_ptr = NULL;
int i = 0;
if (matrix == NULL) return LIBXW_ERRNO_NULLOBJECT;
if (value_ptr == NULL) return LIBXW_ERRNO_NULLARGUMENT;
if (value_len < 0) return LIBXW_ERRNO_MINUSARGUMENT;
headnode = (LIBXW_DATANODE *)matrix;
if ((column < 0) || (column >= headnode->ext.extrec[EXT_COL_INDEX])) return LIBXW_ERRNO_COLINDEX_OUTRANGE;
if ((row < 0) || (row >= headnode->ext.extrec[EXT_ROW_INDEX])) return LIBXW_ERRNO_ROWINDEX_OUTRANGE;
if (((headnode->datatype & NODE_HEADNODE_CLINK) == 0) || ((headnode->datatype & 0xFF) != value_type))
return LIBXW_ERRNO_INVALID_NODETYPE;
/* First, look up if the specified item existed. */
if ((newnode = matrix_lookup_item(headnode, column, row)) != NULL){
/* overwrite the existing node.*/
return set_datanode_value(newnode, value_type, value_ptr, value_len);
}
else{
newnode = get_next_available_node(GLOBAL_BLOCK_TABLE);
if (newnode == NULL){
exit(EXIT_PROCESS_DEBUG_EVENT);
}
set_datanode_value(newnode, value_type, value_ptr, value_len);
newnode->ext.extrec[EXT_COL_INDEX] = column;
newnode->ext.extrec[EXT_ROW_INDEX] = row;
for (cur_ptr = headnode, i = -1; i <= column; cur_ptr = cur_ptr->next, i++){
if (i == column){
flag_ptr = cur_ptr;
if (cur_ptr->prev == flag_ptr){ /* no item yet */
INTEGER_VALUE(flag_ptr) += 1;
newnode->prev = flag_ptr;
flag_ptr->prev = newnode;
}
else{
for (prev_ptr = flag_ptr, cur_ptr = flag_ptr->prev; cur_ptr != flag_ptr; cur_ptr = cur_ptr->prev){
if (cur_ptr != flag_ptr){
if (cur_ptr->ext.extrec[EXT_ROW_INDEX] > row){
INTEGER_VALUE(flag_ptr) += 1;
newnode->prev = cur_ptr;
prev_ptr->prev = newnode;
break;
}
}
prev_ptr = cur_ptr;
}
if (prev_ptr->prev == cur_ptr){
INTEGER_VALUE(flag_ptr) += 1;
newnode->prev = cur_ptr;
prev_ptr->prev = newnode;
}
}
break;
}
}
INTEGER_VALUE(headnode) += 1;
for (cur_ptr = headnode, i = -1; i <= row; cur_ptr = cur_ptr->prev, i++){
if (i == row){
flag_ptr = cur_ptr;
if (cur_ptr->next == flag_ptr){
INTEGER_VALUE(flag_ptr) += 1;
newnode->next = flag_ptr;
flag_ptr->next = newnode;
}
else{
for (prev_ptr = flag_ptr, cur_ptr = flag_ptr->next; cur_ptr != flag_ptr; cur_ptr = cur_ptr->next){
if (cur_ptr != flag_ptr){
if (cur_ptr->ext.extrec[EXT_COL_INDEX] > column){
INTEGER_VALUE(flag_ptr) += 1;
newnode->next = cur_ptr;
prev_ptr->next = newnode;
break;
}
else if (cur_ptr->ext.extrec[EXT_COL_INDEX] == column){
return LIBXW_ERRNO_COLINDEX_EXISTED;
}
else{
;;
}
}
prev_ptr = cur_ptr;
}
if (prev_ptr->next == cur_ptr){
INTEGER_VALUE(flag_ptr) += 1;
newnode->next = cur_ptr;
prev_ptr->next = newnode;
}
}
break;
}
}
return EXIT_SUCCESS;
}
}
/*----------------------------------------------------------------------------------------------------------------------------
------------------------------------------------------------------------------------------------------------------------------
MAIN FUNCTION
------------------------------------------------------------------------------------------------------------------------------
------------------------------------------------------------------------------------------------------------------------------ */
SEXP local_poly_estimator(SEXP X, SEXP Y, SEXP points, SEXP band, SEXP grid1, SEXP degree_poly, SEXP kernel_type1, SEXP deriv1)
{
int i, j;
i = 0;j = 0;
/* Digest the datastructures (SEXPs) from R */
double *xptr, *yptr, *grid;
int kernel_type = INTEGER_VALUE(kernel_type1);
int degree_pol = INTEGER_VALUE(degree_poly);
int deriv = INTEGER_VALUE(deriv1);
PROTECT(grid1 = coerceVector (grid1, REALSXP) ) ;
grid = REAL(grid1);
SEXP dimgrid = coerceVector(getAttrib(grid1, R_DimSymbol), INTSXP);
int n_grid = INTEGER(dimgrid)[1];
// get dimensions of matrix X
SEXP dimX = coerceVector(getAttrib(X, R_DimSymbol), INTSXP);
d = INTEGER(dimX)[0];
n = INTEGER(dimX)[1];
// get dimensions of matrix points
double *pontos;
int n_pontos, d_pontos;
SEXP dimpoints = coerceVector(getAttrib(points, R_DimSymbol), INTSXP);
d_pontos = INTEGER(dimpoints)[0];
n_pontos = INTEGER(dimpoints)[1];
if ((d > 1) && (d_pontos == 1)) // X is a matrix n by d and points is a vector
{ // then, points is one point of d dimension
n_pontos = 1;
d_pontos = d;
}
PROTECT(X = coerceVector (X, REALSXP) ) ;
xptr = REAL(X);
PROTECT(Y = coerceVector (Y, REALSXP) ) ;
yptr = REAL(Y);
PROTECT(points = coerceVector (points, REALSXP) ) ;
pontos = REAL(points);
// aux is at each step the point x at which we predict y
double aux[d];
int k;
// pred is the predicted values that will be returned
SEXP pred;
double *p_pred;
PROTECT(pred = NEW_NUMERIC(n_pontos));
p_pred = NUMERIC_POINTER(pred);
PROTECT(band = coerceVector (band, REALSXP) ) ;
double * banda = REAL(band);
// banda must have dimensions: n_points by d
SEXP bandwidth;
double *p_bandwidth;
PROTECT(bandwidth = NEW_NUMERIC(d*n_pontos));
p_bandwidth = NUMERIC_POINTER(bandwidth);
// ------------------------------------------------------------- Cross Validation or GCV
if ((banda[0] == 0) || (banda[0] == -1))
{
GCV(xptr, yptr, n , d , kernel_type, grid, n_grid, degree_pol, deriv, p_bandwidth);
for (i = 1; i < n_pontos; i++)
for (j = 0; j < d; j++)
p_bandwidth[i*d + j] = p_bandwidth[j];
} else
// ------------------------------------------------------------- Cross Validation or GCV multidimensional
if ((banda[0] == -2) || (banda[0] == -3))
{
GCV_each_dimens(xptr, yptr, n , d , kernel_type, grid, n_grid, degree_pol, deriv, p_bandwidth);
for (i = 1; i < n_pontos; i++)
for (j = 0; j < d; j++)
p_bandwidth[i*d + j] = p_bandwidth[j];
} else
// -------------------------------------------------------------
{ // if no cross-validation, I still need to fill the matrix of bandwidths
// where each row correspond to a point in 'points' sent by the user here
for (i = 0; i < n_pontos; i++)
for (j = 0; j < d; j++)
p_bandwidth[i*d + j] = banda[i*d + j];
}
// variables used to solve (X'X)^-1X'Y
const int m = n;
int n2;
if (degree_pol == 1)
n2 = 1 + d;
else if (degree_pol == 2)
n2 = 1+d + d*(d+1)/2;
else
n2 = degree_pol + 1;
double a[n2*n]; // this will be X
double b[n]; // this will be Y
const int nrhs = 1;
const int lda = n;
const int ldb = n;
int lwork;
int mn = m;
if (n2 < m)
mn = n2;
if (mn == 1)
lwork = mn + 1;
else
lwork = mn + mn;
int info = 0;
double work[lwork];
for(i = 0; i < lwork; i++)
work[i] = 0;
// ------------------------------------------------------------------------------------------------- Prediction
for (i = 0; i < n_pontos; i++)
{
// ------------------------------------ construct aux
//aux is the point where m1 is to be estimated
if (d == 1)
aux[0] = pontos[i];
else
if (n_pontos == 1) // here, X is a matrix n by d (d>1)
for (j = 0; j < d; j++) //and points is a vector size d, thus there is 1 point
aux[j] = pontos[j];
else
{
for (j = 0; j < d; j++)
aux[j] = pontos[i*d + j];
}
// for each observation in X construct a and obtain beta_hat_0 = m_hat(aux)
for (j = 0; j < n; j++)
{
// construct a = sqrt(W)XX
a[j] = 1;
for (k = 1; k <= d; k++)
a[j] = a[j]*sqrt(K(kernel_type, (xptr[j*d + k-1]-aux[k-1])/p_bandwidth[i*d + k-1])); // for a vector of bandwidths
if ((degree_pol == 1) || (degree_pol == 2)) // add columns X1-x, X2-x,... Xd-x
for (k = 1; k <= d; k++)
a[j+n*k] = (xptr[j*d + k-1]-aux[k-1])*a[j]; // note that a is transpose manner
if (degree_pol == 2) // include columns of half vectorization: VECH
{
int l, ind_vech;
ind_vech = 1;
for (k = 1; k <= d; k++)
for (l = k; l <= d; l++)
{
a[j+n*d+n*ind_vech] = (xptr[j*d + k-1]-aux[k-1])*(xptr[j*d + l-1]-aux[l-1])*a[j];
ind_vech = ind_vech + 1;
}
}
if ((degree_pol > 2) && (d == 1)) // works only for d == 1
for (k = 1; k <= degree_pol; k++)
a[j+n*k] = pow((xptr[j]-aux[0]),k)*a[j];
b[j] = yptr[j]*a[j]; // b = sqrt(W)Y
}
// reg does (a'a)^-1a'b
reg(&m, &n2, &nrhs, a, &lda, b, &ldb, work, &lwork, &info);
p_pred[i] = factorial(deriv)*b[deriv];
}
// -------------------------------------------------------------------------------------------------- Prediction
SEXP list, list_names;
char *names[2] = {"predicted", "bandwidth"};
PROTECT(list_names = allocVector(STRSXP,2));
PROTECT(list = allocVector(VECSXP, 2));
for(i = 0; i < 2; i++)
SET_STRING_ELT(list_names,i,mkChar(names[i]));
SET_VECTOR_ELT(list, 0, pred);
SET_VECTOR_ELT(list, 1, bandwidth);
setAttrib(list, R_NamesSymbol, list_names);
UNPROTECT( 9 ) ;
return(list);
}
int __cdecl matrix_resize(LIBXW_MANAGED_MATRIX matrix, int new_col, int new_row, LIBXW_BOOLEAN isforced){
#else
int matrix_resize(LIBXW_MANAGED_MATRIX matrix, int new_col, int new_row, LIBXW_BOOLEAN isforced){
#endif
LIBXW_DATANODE *headnode = NULL, *curnode = NULL, *new_headnode = NULL, *prevnode = NULL,
*delete_node = NULL, *walk_node = NULL, *reset_node = NULL;
int col_idx = 0, row_idx = 0;
LIBXW_VALUE_TYPE value_type;
if (matrix == NULL) return LIBXW_ERRNO_NULLOBJECT;
headnode = (LIBXW_DATANODE *)matrix;
if (!(headnode->datatype & NODE_HEADNODE_CLINK)) return LIBXW_ERRNO_INVALID_NODETYPE;
if (isforced == BOOLEAN_FALSE){
for (curnode = headnode->next;
curnode != headnode;
curnode = curnode->next){
if (curnode->ext.extrec[EXT_COL_INDEX] >= new_col){
if (INTEGER_VALUE(curnode) > 0){
return LIBXW_ERRNO_INVALIDOPRATION;
}
}
}
for (curnode = headnode->prev;
curnode != headnode;
curnode = curnode->prev){
if (curnode->ext.extrec[EXT_ROW_INDEX] >= new_row){
if (INTEGER_VALUE(curnode) > 0){
return LIBXW_ERRNO_INVALIDOPRATION;
}
}
}
}
value_type = headnode->datatype ^ NODE_HEADNODE_CLINK;
if (new_col > headnode->ext.extrec[EXT_COL_INDEX]){
/* Add new colomns */
for (curnode = headnode, col_idx = -1;
((curnode->next != headnode) && (col_idx < headnode->ext.extrec[EXT_COL_INDEX]));
curnode = curnode->next, col_idx++){
;;
}
if (curnode->ext.extrec[EXT_COL_INDEX] != col_idx){
exit(EXIT_PROCESS_DEBUG_EVENT);
}
for (col_idx += 1; col_idx < new_col; col_idx++){
new_headnode = get_next_available_node(GLOBAL_BLOCK_TABLE);
if (new_headnode == NULL){
exit(EXIT_PROCESS_DEBUG_EVENT);
}
new_headnode->datatype = NODE_HEADNODE_CLINK_COLHEAD | value_type;
new_headnode->ext.extrec[EXT_COL_INDEX] = col_idx;
INTEGER_VALUE(new_headnode) = 0;
curnode->next = new_headnode; /* next pointer means right pointer here */
new_headnode->next = headnode;
curnode = curnode->next; /* move the current pointer*/
new_headnode->prev = new_headnode; /* the down pointer should points to the column head itself during initialization*/
}
}
else if (new_col < headnode->ext.extrec[EXT_COL_INDEX]){
/* Delete existing columns */
for (prevnode = headnode, curnode = headnode->next;
curnode != headnode;){
if (curnode->ext.extrec[EXT_COL_INDEX] >= new_col){
if (INTEGER_VALUE(curnode) > 0){
for (delete_node = curnode, walk_node = curnode->prev; walk_node != curnode; ){
delete_node = walk_node;
walk_node = walk_node->prev;
/* Make sure the relation of the row is alright after the delete_node being deleted. */
for (reset_node = delete_node; reset_node->next != delete_node; reset_node = reset_node->next){
if ((reset_node->datatype & 0xFF00) == NODE_HEADNODE_CLINK_ROWHEAD){
INTEGER_VALUE(reset_node) -= 1;
}
}
if ((reset_node->datatype & 0xFF00) == NODE_HEADNODE_CLINK_ROWHEAD){
INTEGER_VALUE(reset_node) -= 1;
}
reset_node->next = delete_node->next;
delete_node->next = NULL;
INTEGER_VALUE(headnode) -= 1;
put_datanode_into_spare(GLOBAL_BLOCK_TABLE, delete_node);
}
curnode->prev = curnode;
}
delete_node = curnode;
curnode = curnode->next;
prevnode->next = curnode;
put_datanode_into_spare(GLOBAL_BLOCK_TABLE, delete_node);
}
else{
prevnode = curnode;
curnode = curnode->next;
}
}
}
else{
;;
}
headnode->ext.extrec[EXT_COL_INDEX] = new_col;
if (new_row > headnode->ext.extrec[EXT_ROW_INDEX]){
/* Add new rows */
for (curnode = headnode, row_idx = -1;
((curnode->prev != headnode) && (row_idx < headnode->ext.extrec[EXT_ROW_INDEX]));
curnode = curnode->prev, row_idx++){
;;
}
if (curnode->ext.extrec[EXT_ROW_INDEX] != row_idx){
exit(EXIT_PROCESS_DEBUG_EVENT);
}
for (row_idx += 1; row_idx < new_col; row_idx++){
new_headnode = get_next_available_node(GLOBAL_BLOCK_TABLE);
if (new_headnode == NULL){
exit(EXIT_PROCESS_DEBUG_EVENT);
}
new_headnode->datatype = NODE_HEADNODE_CLINK_ROWHEAD | value_type;
new_headnode->ext.extrec[EXT_ROW_INDEX] = row_idx;
INTEGER_VALUE(new_headnode) = 0;
curnode->prev = new_headnode; /* next pointer means right pointer here */
new_headnode->prev = headnode;
curnode = curnode->prev; /* move the current pointer*/
new_headnode->next = new_headnode; /* the down pointer should points to the column head itself during initialization*/
}
}
else if (new_row < headnode->ext.extrec[EXT_ROW_INDEX]){
/* Delete existing rows */
for (prevnode = headnode, curnode = headnode->prev;
curnode != headnode;){
if (curnode->ext.extrec[EXT_ROW_INDEX] >= new_row){
if (INTEGER_VALUE(curnode) > 0){
for (delete_node = curnode, walk_node = curnode->next;
walk_node != curnode;){
delete_node = walk_node;
walk_node = walk_node->next;
/* Make sure the relation of the columns is alright after the delete_node being deleted. */
for (reset_node = delete_node; reset_node->prev != delete_node; reset_node = reset_node->prev){
if ((reset_node->datatype & 0xFF00) == NODE_HEADNODE_CLINK_COLHEAD){
INTEGER_VALUE(reset_node) -= 1;
}
}
if ((reset_node->datatype & 0xFF00) == NODE_HEADNODE_CLINK_COLHEAD){
INTEGER_VALUE(reset_node) -= 1;
}
reset_node->prev = delete_node->prev;
delete_node->prev = NULL;
INTEGER_VALUE(headnode) -= 1;
put_datanode_into_spare(GLOBAL_BLOCK_TABLE, delete_node);
}
curnode->next = curnode;
}
delete_node = curnode;
curnode = curnode->prev;
prevnode->prev = curnode;
put_datanode_into_spare(GLOBAL_BLOCK_TABLE, delete_node);
}
else{
prevnode = curnode;
curnode = curnode->prev;
}
}
}
else{
;;
}
headnode->ext.extrec[EXT_ROW_INDEX] = new_row;
return EXIT_SUCCESS;
}
SEXP dieharder(SEXP genS, SEXP testS, SEXP seedS, SEXP psamplesS, SEXP verbS, SEXP infileS, SEXP ntupleS) {
/* In the RDieHarder/R/zzz.R startup code, dieharderGenerators()
* has already called dieharder_rng_types(), and dieharderTests()
* has already called dieharder_rng_tests(). The results are
* stored in RDieHarder:::.dieharderGenerators and
* RDieHarder:::.dieharderTests, as well as C static variables
* used by libdieharder. Since user defined generators and tests
* may have been added, we do not call these routines again.
*/
int verb;
char *inputfile;
char *argv[] = { "dieharder" }; /* Setup argv to allow call of parsecl() to let dieharder set globals */
optind = 0;
parsecl(1, argv); /* also covers part of setup_globals() */
generator = INTEGER_VALUE(genS); /* 'our' parameters from R; used below by choose_rng() and run_test() */
dtest_num = INTEGER_VALUE(testS);
Seed = (unsigned long int) INTEGER_VALUE(seedS); /* (user-select) Seed, not (save switch) seed */
psamples = INTEGER_VALUE(psamplesS);
verb = INTEGER_VALUE(verbS);
inputfile = (char*) CHARACTER_VALUE(infileS);
ntuple = INTEGER_VALUE(ntupleS);
result = NULL;
if (strcmp(inputfile, "") != 0) {
strncpy(filename, inputfile, 128);
fromfile = 1; /* flag this as file input */
}
if (Seed == 0) {
seed = random_seed();
} else {
seed = (unsigned long int) Seed;
}
if (verb) {
Rprintf("Dieharder called with gen=%d test=%d seed=%lu\n", generator, dtest_num, seed);
quiet = 0;
hist_flag = 1;
} else {
quiet = 1; /* override dieharder command-line default */
hist_flag = 0;
}
/*
* Pick a rng, establish a seed based on how things were initialized
* in parsecl() or elsewhere. Note that choose_rng() times the selected
* rng as a matter of course now.
*/
choose_rng();
/*
* At this point, a valid rng should be selected, allocated, and
* provisionally seeded. It -a(ll) is set (CLI only) run all the
* available tests on the selected rng, reseeding at the beginning of
* each test if Seed is nonzero. Otherwise, run the single selected
* test (which may still return a vector of pvalues) on the single
* selected rng. The CLI then goes on to exit; an interactive UI would
* presumably loop back to permit the user to run another test on the
* selected rng or select a new rng (and run more tests on it) until the
* user elects to exit.
*
* It is the UI's responsibility to ensure that run_test() is not called
* without choosing a valid rng first!
*/
/* if(all){ */
/* run_all_tests(); */
/* } else { */
run_test();
/* } */
/*
* This ends the core loop for a non-CLI interactive UI. GUIs will
* typically exit directly from the event loop. Tool UIs may well fall
* through, and the CLI simply proceeds sequentially to exit. It isn't
* strictly necessary to execute an exit() command at the end, but it
* does make the code a bit clearer (and let's one choose an exit code,
* if that might ever matter. Exit code 0 clearly means "completed
* normally".
*/
if (rng != NULL) {
gsl_rng_free(rng);
rng = NULL;
}
reset_bit_buffers();
return result; /* And then bring our results back to R */
}
SEXP
m_log_lambda(SEXP X1, SEXP X1_Columns, SEXP X1_Rows,
SEXP X2, SEXP X2_Columns,
SEXP realS, SEXP OPTSimplicit_noisevar,
SEXP hp_prior, SEXP hp_posterior) {
long datalen;
int dim1, dim2, ncentroids;
double *Mu_mu, *S2_mu, *Mu_bar, *Mu_tilde,
*Alpha_ksi, *Beta_ksi, *Ksi_alpha, *Ksi_beta, *U_p, *prior_alpha,
*post_gamma, *log_lambda;
double *data1;
double *data2;
SEXP olog_lambda, oU_hat;
SEXP* U_hat;
double *Ns;
double implicit_noisevar;
/******************** input variables ********************/
/************ CONVERTED input variables ******************/
/* data */
PROTECT(X1 = AS_NUMERIC(X1));
data1 = NUMERIC_POINTER(X1);
dim1 = INTEGER_VALUE(X1_Columns);
datalen = INTEGER_VALUE(X1_Rows);
PROTECT(X2 = AS_NUMERIC(X2));
data2 = NUMERIC_POINTER(X2);
dim2 = INTEGER_VALUE(X2_Columns);
Ns = NUMERIC_POINTER(realS);
implicit_noisevar = NUMERIC_VALUE(OPTSimplicit_noisevar);
/* Converted Initial Values of Model Parameters */
if(dim1) {
Mu_mu = NUMERIC_POINTER(getListElement(hp_prior,"Mu_mu"));
S2_mu = NUMERIC_POINTER(getListElement(hp_prior,"S2_mu"));
Alpha_ksi = NUMERIC_POINTER(getListElement(hp_prior,"Alpha_ksi"));
Beta_ksi = NUMERIC_POINTER(getListElement(hp_prior,"Beta_ksi"));
Mu_bar = NUMERIC_POINTER(getListElement(hp_posterior,"Mu_bar"));
Mu_tilde = NUMERIC_POINTER(getListElement(hp_posterior,"Mu_tilde"));
Ksi_alpha = NUMERIC_POINTER(getListElement(hp_posterior,"Ksi_alpha"));
Ksi_beta = NUMERIC_POINTER(getListElement(hp_posterior,"Ksi_beta"));
}
if(dim2) {
U_p = NUMERIC_POINTER(getListElement(hp_prior,"U_p"));
oU_hat = getListElement(hp_posterior,"Uhat");
U_hat = &oU_hat;
}
prior_alpha = NUMERIC_POINTER(getListElement(hp_prior,"alpha"));
post_gamma = NUMERIC_POINTER(getListElement(hp_posterior,"gamma"));
ncentroids = INTEGER_POINTER( GET_DIM(getListElement(hp_posterior,"Mu_bar")) )[0];
/*printf("\nMu_mu ");
for(i=0; i< dim1;i++)
printf("%f ", Mu_mu[i]);
printf("\nS2_mu ");
for(i=0; i< dim1;i++)
printf("%f ", S2_mu[i]);
printf("\nAlpha_ksi ");
for(i=0; i< dim1;i++)
printf("%f ", Alpha_ksi[i]);
printf("\nBeta_ksi ");
for(i=0; i< dim1;i++)
printf("%f ", Beta_ksi[i]);
printf("\nMu_bar ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Mu_bar[i]);
printf("\nMu_tilde ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Mu_tilde[i]);
printf("\nKsi_alpha ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Ksi_alpha[i]);
printf("\nKsi_beta ");
for(i=0;i<ncentroids*dim1;i++)
printf("%f ", Ksi_beta[i]);
printf("\nprior_alpha = %f", *prior_alpha);
printf("\npost_gamma ");
for(i=0;i<2*ncentroids;i++)
printf("%f ", post_gamma[i]);
printf("ncentroids = %d\n", ncentroids);
printf("dim2 = %d\n",dim2);*/
/******************** output variables ********************/
PROTECT(olog_lambda = NEW_NUMERIC(datalen*ncentroids));
log_lambda = NUMERIC_POINTER(olog_lambda);
vdp_mk_log_lambda(Mu_mu, S2_mu, Mu_bar, Mu_tilde,
Alpha_ksi, Beta_ksi, Ksi_alpha, Ksi_beta,
post_gamma, log_lambda, prior_alpha,
U_p, U_hat,
datalen, dim1, dim2, data1, data2,
Ns, ncentroids, implicit_noisevar);
UNPROTECT(3);
return olog_lambda;
}
