Пример #1
0
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);  
}
Пример #2
0
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);
}
Пример #3
0
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, &gt_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;
}
Пример #4
0
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);
}
Пример #5
0
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;
}
Пример #7
0
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;
}
Пример #8
0
/*!
  \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 */
Пример #9
0
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("");
		}
	}
Пример #10
0
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;
}
Пример #12
0
/* 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);
}
Пример #13
0
  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 とセットされる
	
	// 	///////////////////////////////////////////////////////
  }
Пример #14
0
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);
}
Пример #15
0
//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);
}
Пример #16
0
/*!
  \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 */
Пример #17
0
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);
}
Пример #18
0
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;
}
Пример #19
0
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;
    }
}
Пример #20
0
/*----------------------------------------------------------------------------------------------------------------------------
 ------------------------------------------------------------------------------------------------------------------------------
 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);
}
Пример #21
0
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;
}
Пример #22
0
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 */
}
Пример #23
0
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;
}