C++ (Cpp) ChildTwoVarCompModel Examples

Example #1

SEXP rint_flmm(SEXP pexplan_sexp, SEXP presp_sexp, SEXP pn_sexp, SEXP pp_sexp, SEXP pcovar_sexp, SEXP pp_covar_sexp, SEXP pVar2_sexp, SEXP nu_naught_sexp, SEXP gamma_naught_sexp)
{

  double *pexplan, *presp,  *pnu_naught, *pgamma_naught, *pcovar, *pVar2;
  double* pchisq;
  double* pherit;
  unsigned int *pn, *pp_covar, *pp;
 

  char pret_names[][100]={"chi.sq", "herit", "null.herit"};

  SEXP preturn_list_SEXP, preturn_names_SEXP, paname_SEXP;
    
  SEXP pchisq_SEXP;
  SEXP pherit_SEXP;
  SEXP pnullherit_SEXP;

  gsl_matrix* pvar1_mat, *pvar2_mat;
  gsl_matrix* pcovar_mat;
 
  gsl_vector* presponse_vec;

  double* pnullherit;
      
  // really must check all gsl returns
  //gsl_set_error_handler_off();

  // C side pointers to R objects
  pexplan=(double*) REAL(pexplan_sexp);
  presp=(double*) REAL(presp_sexp);
  pn=(unsigned int*) INTEGER(pn_sexp);
  pp=(unsigned int*) INTEGER(pp_sexp);
  pcovar=(double*) REAL(pcovar_sexp);
  pp_covar=(unsigned int*) INTEGER(pp_covar_sexp);
  pVar2=(double*) REAL(pVar2_sexp);
  pnu_naught=(double*)REAL(nu_naught_sexp);
  pgamma_naught=(double*)REAL(gamma_naught_sexp);
  

  presponse_vec=&(gsl_vector_view_array(presp, *pn).vector);
  pvar2_mat=&(gsl_matrix_view_array(pVar2, *pn, *pn).matrix);
  pvar1_mat=gsl_matrix_alloc(*pn, *pn);
  pcovar_mat=&(gsl_matrix_view_array(pcovar, *pn, *pp_covar).matrix);
  
  gsl_matrix* pincid1_mat, *pincid2_mat;
 
  pincid1_mat=gsl_matrix_alloc(*pn,*pn);
  pincid2_mat=gsl_matrix_alloc(*pn,*pn);

  gsl_matrix_set_identity(pvar1_mat);
  // gsl_matrix_set_identity(pvar2_mat); 
  gsl_matrix_set_identity(pincid1_mat);
  gsl_matrix_set_identity(pincid2_mat); 

   
  PROTECT(pchisq_SEXP=NEW_NUMERIC(*pp));
  pchisq=NUMERIC_POINTER(pchisq_SEXP);
  PROTECT(pherit_SEXP=NEW_NUMERIC(*pp));
  pherit=NUMERIC_POINTER(pherit_SEXP);
  PROTECT(pnullherit_SEXP=NEW_NUMERIC(1));
  pnullherit=NUMERIC_POINTER(pnullherit_SEXP);

    
  TwoVarCompModel DaddyTwoVarCompModel(presponse_vec, pcovar_mat, pvar1_mat, pvar2_mat, pincid1_mat, pincid2_mat);  
  double nullminimand=0.5;
  double altminimand;
  double nulldev=DaddyTwoVarCompModel.MinimiseNullDeviance(&nullminimand);
  *pnullherit=nullminimand;
  //std::cout << "null sigmasq=" << nullminimand<<std::endl<<std::endl;
  //DaddyTwoVarCompModel.NullDeviance(0.5);
  
#pragma omp parallel shared(pexplan, pp, pn, pchisq, pherit, nulldev, nullminimand) private(altminimand)
    {
      TwoVarCompModel ChildTwoVarCompModel(DaddyTwoVarCompModel);
      
#pragma omp for
      for(int it=0;it<*pp;it++)
	{
#pragma omp critical
	  { 
	    std::cout<<".";
	  }
	  TwoVarCompModel ATwoVarCompModel(DaddyTwoVarCompModel);
	  ChildTwoVarCompModel.SetExplan(&(gsl_vector_view_array(pexplan+(*pn)*it, *pn).vector));
	  altminimand=nullminimand;
	  pchisq[it]=nulldev-ChildTwoVarCompModel.MinimiseDeviance(&altminimand);
	  pherit[it]=altminimand;
	
	}    
    }
  
  

  PROTECT(preturn_list_SEXP=allocVector(VECSXP,3));
  SET_VECTOR_ELT(preturn_list_SEXP, 0,pchisq_SEXP);
  SET_VECTOR_ELT(preturn_list_SEXP, 1,pherit_SEXP);
  SET_VECTOR_ELT(preturn_list_SEXP, 2,pnullherit_SEXP);
 
 
  PROTECT(preturn_names_SEXP=allocVector(STRSXP,3));

  
  for(int it=0;it<3;it++)
    {
      
      PROTECT(paname_SEXP=Rf_mkChar(pret_names[it]));
      SET_STRING_ELT(preturn_names_SEXP,it,paname_SEXP);
    }
  setAttrib(preturn_list_SEXP, R_NamesSymbol,preturn_names_SEXP);
  
  UNPROTECT(8);

  return preturn_list_SEXP;
}

Example #2

File: main.cpp Project: rforge/genabel

SEXP rint_flmm(SEXP pexplan_sexp, SEXP presp_sexp, SEXP pn_sexp, SEXP pp_sexp, SEXP pcovar_sexp, SEXP pp_covar_sexp, SEXP pVar2_sexp, SEXP nu_naught_sexp, SEXP gamma_naught_sexp)
{

  double *pexplan, *presp,  *pnu_naught, *pgamma_naught, *pcovar, *pVar2;
  double* pchisq;
  double* pherit;
  unsigned int *pn, *pp_covar, *pp;
 

  char pret_names[][100]={"coefs", "chi.sq", "herit", "null.herit"};

  SEXP preturn_list_SEXP, preturn_names_SEXP, paname_SEXP;
    
  SEXP pchisq_SEXP;
  SEXP pherit_SEXP;
  SEXP pbeta_SEXP;
  SEXP pnullherit_SEXP;

  gsl_matrix* pvar1_mat, *pvar2_mat;
  gsl_matrix* pcovar_mat;
 
  gsl_vector* presponse_vec;

  double* pnullherit;
  double* pbeta;
  

  // really must check all gsl returns
  gsl_set_error_handler_off();

  // C side pointers to R objects
  pexplan=(double*) REAL(pexplan_sexp);
  presp=(double*) REAL(presp_sexp);
  pn=(unsigned int*) INTEGER(pn_sexp);
  pp=(unsigned int*) INTEGER(pp_sexp);
  pcovar=(double*) REAL(pcovar_sexp);
  pp_covar=(unsigned int*) INTEGER(pp_covar_sexp);
  pVar2=(double*) REAL(pVar2_sexp);
  pnu_naught=(double*) REAL(nu_naught_sexp);
  pgamma_naught=(double*) REAL(gamma_naught_sexp);
  
  
  /* gsl_vector_view response_vecview=gsl_vector_view_array(presp, *pn);
     presponse_vec=&(response_vecview.vector);*/
  gsl_matrix_view var2_matview=gsl_matrix_view_array(pVar2, *pn, *pn);
  pvar2_mat=&(var2_matview.matrix);
  // freed
  pvar1_mat=gsl_matrix_alloc(*pn, *pn);
  /* gsl_matrix_view covar_matview=gsl_matrix_view_array(pcovar, *pn, *pp_covar);
     pcovar_mat=&(covar_matview.matrix);*/

  // sort out missing in response
  // better to bulk copy then iterate?
  unsigned int it;
  unsigned int nonzerocount=0;
  // freed
  presponse_vec=gsl_vector_alloc(*pn);
  double meanval=0.0;
  for(it=0;it<*pn;it++)
    {
      if(!ISNA(presp[it]))
	{
	  meanval+=presp[it];
	  nonzerocount+=1;
	}
    }
  meanval/=(double) nonzerocount;
  
  for(it=0;it<*pn;it++)
    {
      if(ISNA(presp[it]))
	gsl_vector_set(presponse_vec, it, meanval);
      else
	gsl_vector_set(presponse_vec, it, presp[it]);  
    }

  // freed
  pcovar_mat=gsl_matrix_alloc( *pn, *pp_covar);
  unsigned it2;
  for(it2=0;it2<*pp_covar;it2++)
    {
      meanval=0.0;
      nonzerocount=0;
      for(it=0;it<*pn;it++)
	{
	  if(!ISNA(pcovar[it*(*pp_covar)+it2]))
	    {
	      meanval+=pcovar[it*(*pp_covar)+it2];
	      nonzerocount+=1;
	    }
	}
      meanval/=(double) nonzerocount;
      for(it=0;it<*pn;it++)
	{
	  if(ISNA(pcovar[it*(*pp_covar)+it2]))
	    gsl_matrix_set(pcovar_mat, it, it2, meanval);
	  else
	    gsl_matrix_set(pcovar_mat, it, it2, pcovar[it*(*pp_covar)+it2]);  
	}
    }

  
  /*std::cout<<"cov="<<pcovar[0]<<","<<pcovar[1]<<","<<pcovar[2]<<std::endl;
    std::cout<<"pcovar_mat";
  gslprint(pcovar_mat);*/
  

  gsl_matrix* pincid1_mat, *pincid2_mat;
 
  // freed
  pincid1_mat=gsl_matrix_alloc(*pn,*pn);
  //freed
  pincid2_mat=gsl_matrix_alloc(*pn,*pn);

  gsl_matrix_set_identity(pvar1_mat);
  // gsl_matrix_set_identity(pvar2_mat); 
  gsl_matrix_set_identity(pincid1_mat);
  gsl_matrix_set_identity(pincid2_mat); 

  PROTECT(pbeta_SEXP=NEW_NUMERIC(*pp));
  pbeta=NUMERIC_POINTER(pbeta_SEXP);
  PROTECT(pchisq_SEXP=NEW_NUMERIC(*pp));
  pchisq=NUMERIC_POINTER(pchisq_SEXP);
  PROTECT(pherit_SEXP=NEW_NUMERIC(*pp));
  pherit=NUMERIC_POINTER(pherit_SEXP);
  PROTECT(pnullherit_SEXP=NEW_NUMERIC(1));
  pnullherit=NUMERIC_POINTER(pnullherit_SEXP);

  
  TwoVarCompModel DaddyTwoVarCompModel(presponse_vec, pcovar_mat, pvar1_mat, pvar2_mat, pincid1_mat, pincid2_mat, pnu_naught, pgamma_naught);  
  double nullminimand=0.5;
  double altminimand;
  double nulldev=DaddyTwoVarCompModel.MinimiseNullDeviance(&nullminimand);
  *pnullherit=nullminimand;
  
  /*std::cout<<"si==0.2"<<std::endl<<DaddyTwoVarCompModel.NullDeviance(0.2)<<std::endl;	 
  std::cout<<"si==0.4"<<std::endl<<DaddyTwoVarCompModel.NullDeviance(0.4)<<std::endl;	 
  std::cout<<"si==0.6"<<std::endl<<DaddyTwoVarCompModel.NullDeviance(0.6)<<std::endl;
  std::cout<<"si==0.8"<<std::endl<<DaddyTwoVarCompModel.NullDeviance(0.8)<<std::endl;
  */
  
 
  pgsl_vector* ppexplantemp_vec = new pgsl_vector[OMP_GET_MAX_THREADS];
  pgsl_vector* ppbeta_vec=new pgsl_vector[OMP_GET_MAX_THREADS];
  for(it=0;it<OMP_GET_MAX_THREADS;it++)
    {
      ppexplantemp_vec[it]=gsl_vector_alloc(*pn);
      ppbeta_vec[it]=gsl_vector_alloc(1);

    }
  #pragma omp parallel for shared(pexplan, pp, pn, pchisq, pherit, nulldev, nullminimand, ppexplantemp_vec, pbeta, ppbeta_vec) private(altminimand, it2, meanval, nonzerocount)
  for(it=0;it<*pp;it++)
    {
      TwoVarCompModel ChildTwoVarCompModel(DaddyTwoVarCompModel);
//      std::cout<<".";
      
      meanval=0.0;
      nonzerocount=0;
      for(it2=0;it2<*pn;it2++)
	{
	  if(!ISNA(pexplan[it2+(*pn)*it]))
		{
		  meanval+=pexplan[it2+(*pn)*it];
		  nonzerocount+=1;
		}
	}
      meanval/=(double) nonzerocount;
      
      for(it2=0;it2<*pn;it2++)
	{
	  if(ISNA(pexplan[it2+(*pn)*it]))
	    gsl_vector_set(ppexplantemp_vec[OMP_GET_THREAD_NUM], it2, meanval);
	  else
	    gsl_vector_set(ppexplantemp_vec[OMP_GET_THREAD_NUM], it2, pexplan[it2+(*pn)*it]);  
	}
      ChildTwoVarCompModel.SetExplan(ppexplantemp_vec[OMP_GET_THREAD_NUM]);
      altminimand=nullminimand;
    
      pchisq[it]=nulldev-ChildTwoVarCompModel.MinimiseDeviance(&altminimand);
      
      pherit[it]=altminimand;
      ChildTwoVarCompModel.GetBeta(ppbeta_vec[OMP_GET_THREAD_NUM], altminimand);
      pbeta[it]=gsl_vector_get(ppbeta_vec[OMP_GET_THREAD_NUM], 0);
      
    }
  for(it=0;it<OMP_GET_MAX_THREADS;it++)
    {
      gsl_vector_free(ppexplantemp_vec[it]);
      gsl_vector_free(ppbeta_vec[it]);
    }
  delete[] ppexplantemp_vec;
  delete[] ppbeta_vec;
  
  gsl_matrix_free(pvar1_mat);
  gsl_vector_free(presponse_vec);
  gsl_matrix_free(pcovar_mat);
  gsl_matrix_free(pincid1_mat);
  gsl_matrix_free(pincid2_mat);
  
  
  PROTECT(preturn_list_SEXP=allocVector(VECSXP,4));
  SET_VECTOR_ELT(preturn_list_SEXP, 0,pbeta_SEXP);
  SET_VECTOR_ELT(preturn_list_SEXP, 1,pchisq_SEXP);
  SET_VECTOR_ELT(preturn_list_SEXP, 2,pherit_SEXP);
  SET_VECTOR_ELT(preturn_list_SEXP, 3,pnullherit_SEXP);
 
 
  PROTECT(preturn_names_SEXP=allocVector(STRSXP,4));

  
  for(int it=0;it<4;it++)
    {
      
      PROTECT(paname_SEXP=Rf_mkChar(pret_names[it]));
      SET_STRING_ELT(preturn_names_SEXP,it,paname_SEXP);
    }
  setAttrib(preturn_list_SEXP, R_NamesSymbol,preturn_names_SEXP);
  
  UNPROTECT(10);

  return preturn_list_SEXP;
}