/* ev_err -- reports error (err_num) in file "file" at line "line_num" and returns to user error handler; list_num is an error list number (0 is the basic list pointed by err_mesg, 1 is the basic list of warnings) */ int ev_err(char *file,int err_num,int line_num,char *fn_name,int list_num) { int num; if ( err_num < 0 ) err_num = 0; #ifndef USING_R if (list_num < 0 || list_num >= err_list_end || err_list[list_num].listp == (char **)NULL) { fprintf(stderr, "\n Not (properly) attached list of errors: list_num = %d\n", list_num); fprintf(stderr," Call \"err_list_attach\" in your program\n"); if ( ! isatty(fileno(stdout)) ) { fprintf(stderr, "\n Not (properly) attached list of errors: list_num = %d\n", list_num); fprintf(stderr," Call \"err_list_attach\" in your program\n"); } printf("\nExiting program\n"); exit(0); } #endif num = err_num; if ( num >= err_list[list_num].len ) num = 0; #ifndef USING_R if ( cnt_errs && ++num_errs >= MAX_ERRS ) /* too many errors */ { fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); if ( ! isatty(fileno(stdout)) ) fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); printf("Sorry, too many errors: %d\n",num_errs); printf("Exiting program\n"); exit(0); } #endif if ( err_list[list_num].warn ) switch ( err_flag ) { case EF_SILENT: break; default: #ifdef USING_R Rprintf("\n\"%s\", line %d: %s in function %s()\n\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); #else fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); if ( ! isatty(fileno(stdout)) ) fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); #endif break; } else switch ( err_flag ) { case EF_SILENT: longjmp(restart,(err_num==0)? -1 : err_num); break; case EF_ABORT: #ifdef USING_R Rprintf("\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); #else fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); if ( ! isatty(fileno(stdout)) ) fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); #endif #ifdef USING_R Rf_error(""); #else abort(); #endif break; case EF_JUMP: #ifdef USING_R Rprintf("\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); #else fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); if ( ! isatty(fileno(stdout)) ) fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); #endif longjmp(restart,(err_num==0)? -1 : err_num); break; case EF_R_ERROR: #ifdef USING_R /* EJP */ Rprintf("\n\"%s\", line %d: %s in function %s()\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); s_gstat_error(isascii(*fn_name) ? fn_name : "???", 0); #endif break; default: #ifdef USING_R Rprintf("\n\"%s\", line %d: %s in function %s()\n\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); #else fprintf(stderr,"\n\"%s\", line %d: %s in function %s()\n\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); if ( ! isatty(fileno(stdout)) ) fprintf(stdout,"\n\"%s\", line %d: %s in function %s()\n\n", file,line_num,err_list[list_num].listp[num], isascii(*fn_name) ? fn_name : "???"); #endif break; } /* ensure exit if fall through */ if ( ! err_list[list_num].warn ) #ifdef USING_R /* EJP */ s_gstat_error("err.c", 0); #else exit(0); #endif return 0; }
void convert_snp_affymetrix_C(char **dirname_, char **filelist, unsigned *files_amount_, char **map_filename_, char **outfilename_, unsigned *skipaffym, char **alleleID_names, char *alleleID, unsigned *alleleID_amount) { char *outfilename = *outfilename_; char *dirname = *dirname_; char *map_filename = *map_filename_; unsigned files_amount=*files_amount_; std::map<std::string, char> coding; for(unsigned i=0 ; i<*alleleID_amount ; i++) { coding[alleleID_names[i]] = alleleID[i]; } Rprintf("reading map...\n"); //std::cout<<"reading map...\n"; AffymetrixChipMap Map(map_filename, 2, 0, 2, 4, 5, 3, 9, 10, 6); //std::cout<<"map is read...\n"; Rprintf("map is read...\n"); if(Map.get_exclude_amount() != 0) { Rprintf("%i SNPs excluded from annotation because of absent enough information annotation file\n", Map.get_exclude_amount()); } std::vector<ChipData *> ids_chip; for(unsigned i=0 ; i<files_amount ; i++) { std::string file = (std::string(dirname) + "/" + std::string(filelist[i])); Rprintf("%i: opening file %s\n", i+1, file.c_str()); ids_chip.push_back(new affymetrix_chip_data(file, 0, 1, *skipaffym)); } unsigned id_amount=ids_chip.size(); std::ofstream outfile(outfilename); if(!outfile.is_open()){error("Can not open file \"\"\n",outfilename);} Rprintf("Save to file %s\n", outfilename); outfile << "#GenABEL raw data version 0.1\n"; //save IDs Rprintf("saving Id names...\n"); for(unsigned id=0 ; id<files_amount ; id++) { outfile<<replace(std::string(filelist[id]), ' ', '_')<<" "; } outfile<<"\n"; std::string snpname; unsigned long snp_excludet_from_output_data=0; //save snpnames Rprintf("saving SNP names...\n"); unsigned snp_amount=ids_chip[0]->get_snp_amount(); for(unsigned snp=0 ; snp<snp_amount ; snp++) { snpname = ids_chip[0]->get_snp_name(snp); if(Map.is_snp_in_map(snpname)){outfile<<Map.recode_snp(snpname.c_str())<<" ";} else{snp_excludet_from_output_data++;} } outfile<<"\n"; //save chromosome Rprintf("saving chromosome data...\n"); for(unsigned snp=0 ; snp<snp_amount ; snp++) { snpname = ids_chip[0]->get_snp_name(snp); if(Map.is_snp_in_map(snpname)){outfile<<Map.get_chromosome(snpname.c_str())<<" ";} } outfile<<"\n"; //save position (map) Rprintf("saving position data...\n"); for(unsigned snp=0 ; snp<snp_amount ; snp++) { snpname = ids_chip[0]->get_snp_name(snp); if(Map.is_snp_in_map(snpname)){outfile<<Map.get_phisical_position(snpname.c_str())<<" ";} } outfile<<"\n"; //save coding Rprintf("saving coding data...\n"); outfile.flags(std::ios_base::hex); //for what is it <-? for(unsigned snp=0 ; snp<snp_amount ; snp++) { snpname = ids_chip[0]->get_snp_name(snp); if(Map.is_snp_in_map(snpname)) { outfile.width(2); outfile.fill('0'); static std::string allele_A, allele_B; allele_A = Map.get_allele_A(snpname.c_str()); allele_B = Map.get_allele_B(snpname.c_str()); outfile<<unsigned(coding[allele_A+allele_B])<<" "; } } outfile<<"\n"; //save strand Rprintf("saving strand data...\n"); std::map<char, unsigned> strand_recode; strand_recode['u']=0; strand_recode['+']=1; strand_recode['-']=2; for(unsigned snp=0 ; snp<snp_amount ; snp++) { snpname = ids_chip[0]->get_snp_name(snp); if(Map.is_snp_in_map(snpname)) { outfile.width(2); outfile.fill('0'); static char strand; strand = Map.get_strand(snpname.c_str()); outfile<<strand_recode[strand]<<" "; } } outfile<<"\n"; //save polymorphism data Rprintf("saving polymorphism data...\n"); unsigned long gtps_byte_amount = (unsigned long)ceil((double)id_amount/4.); char *gtps_for_one_snp = new char[gtps_byte_amount]; unsigned *rearrangement_array = new unsigned[4]; rearrangement_array[0] = 6; rearrangement_array[1] = 4; rearrangement_array[2] = 2; rearrangement_array[3] = 0; for(unsigned snp=0 ; snp<snp_amount ; snp++) { if(!Map.is_snp_in_map(ids_chip[0]->get_snp_name(snp))) {continue;} // skip SNP if it doesn't exsist in our MAP for(unsigned i=0 ; i<gtps_byte_amount ; i++) gtps_for_one_snp[i]=0; static unsigned counter1, counter2; counter1=counter2=0; for(unsigned id=0 ; id<id_amount ; id++) { gtps_for_one_snp[counter2] = gtps_for_one_snp[counter2] | ids_chip[id]->get_polymorphism(snp) << rearrangement_array[counter1]; counter1++; if(counter1==4) {counter1=0; counter2++;} } for(unsigned id=0 ; id<gtps_byte_amount ; id++) { outfile.width(2); outfile.fill('0'); outfile<<unsigned(gtps_for_one_snp[id]&0xFF)<<" "; } outfile<<"\n"; } delete gtps_for_one_snp; delete rearrangement_array; Rprintf("%i SNPs excluded bacause of absent in annotation\n", snp_excludet_from_output_data); Rprintf("Total %i SNPs are written into output file\n", snp_amount-snp_excludet_from_output_data); Rprintf("Finshed... Data saved into file %s\n", outfilename); outfile.close(); }
/* sbart() : The cubic spline smoother ------- Calls sgram (sg0,sg1,sg2,sg3,knot,nk) stxwx (xs,ys,ws,n,knot,nk,xwy,hs0,hs1,hs2,hs3) sslvrg (penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, coef,sz,lev,crit,icrit, lambda, xwy, hs0,hs1,hs2,hs3, sg0,sg1,sg2,sg3, abd,p1ip,p2ip,ld4,ldnk,ier) is itself called from qsbart() [./qsbart.f] which has only one work array Now allows to pass 'lambda' (not just 'spar') via spar[0] == *spar iff *isetup = 2 */ void F77_SUB(sbart) (double *penalt, double *dofoff, double *xs, double *ys, double *ws, double *ssw, int *n, double *knot, int *nk, double *coef, double *sz, double *lev, double *crit, int *icrit, double *spar, int *ispar, int *iter, double *lspar, double *uspar, double *tol, double *eps, double *Ratio, int *isetup, double *xwy, double *hs0, double *hs1, double *hs2, double *hs3, double *sg0, double *sg1, double *sg2, double *sg3, double *abd, double *p1ip, double *p2ip, int *ld4, int *ldnk, int *ier) { /* A Cubic B-spline Smoothing routine. The algorithm minimises: (1/n) * sum ws(i)^2 * (ys(i)-sz(i))^2 + lambda* int ( s"(x) )^2 dx lambda is a function of the spar which is assumed to be between 0 and 1 INPUT ----- penalt A penalty > 1 to be used in the gcv criterion dofoff either `df.offset' for GCV or `df' (to be matched). n number of data points ys(n) vector of length n containing the observations ws(n) vector containing the weights given to each data point NB: the code alters the values here. xs(n) vector containing the ordinates of the observations ssw `centered weighted sum of y^2' nk number of b-spline coefficients to be estimated nk <= n+2 knot(nk+4) vector of knot points defining the cubic b-spline basis. To obtain full cubic smoothing splines one might have (provided the xs-values are strictly increasing) spar penalised likelihood smoothing parameter ispar indicating if spar is supplied (ispar=1) or to be estimated lspar, uspar lower and upper values for spar search; 0.,1. are good values tol, eps used in Golden Search routine isetup setup indicator initially 0 or 2 (if 'spar' is lambda) NB: this alters that, and it is a constant in the caller! icrit indicator saying which cross validation score is to be computed 0: none ; 1: GCV ; 2: CV ; 3: 'df matching' ld4 the leading dimension of abd (ie ld4=4) ldnk the leading dimension of p2ip (not referenced) OUTPUT ------ coef(nk) vector of spline coefficients sz(n) vector of smoothed z-values lev(n) vector of leverages crit either ordinary or generalized CV score spar if ispar != 1 lspar == lambda (a function of spar and the design if(setup != 1) iter number of iterations needed for spar search (if ispar != 1) ier error indicator ier = 0 ___ everything fine ier = 1 ___ spar too small or too big problem in cholesky decomposition Working arrays/matrix xwy X'Wy hs0,hs1,hs2,hs3 the non-zero diagonals of the X'WX matrix sg0,sg1,sg2,sg3 the non-zero diagonals of the Gram matrix SIGMA abd (ld4, nk) [ X'WX + lambda*SIGMA ] = R'R in banded form; output = R p1ip(ld4, nk) inner products between columns of R^{-1} p2ip(ldnk,nk) all inner products between columns of R inverse where R'R = [X'WX + lambda*SIGMA] NOT REFERENCED */ // "Correct" ./sslvrg.f (line 129): crit = 3 + (dofoff-df)**2 #define CRIT(FX) (*icrit == 3 ? FX - 3. : FX) /* cancellation in (3 + eps) - 3, but still...informative */ #define BIG_f (1e100) /* c_Gold is the squared inverse of the golden ratio */ static const double c_Gold = 0.381966011250105151795413165634; /* == (3. - sqrt(5.)) / 2. */ /* Local variables */ static double ratio;/* must be static (not needed in R) */ double a, b, d, e, p, q, r, u, v, w, x; double ax, fu, fv, fw, fx, bx, xm; double tol1, tol2; int i, maxit; Rboolean Fparabol = FALSE, tracing = (*ispar < 0), spar_is_lambda = FALSE; /* unnecessary initializations to keep -Wall happy */ d = 0.; fu = 0.; u = 0.; // never computed if(spar_is_lambda) ratio = 1.; /* Compute SIGMA, X' W X, X' W z, trace ratio, s0, s1. SIGMA -> sg0,sg1,sg2,sg3 -- via sgram() in ./sgram.f X' W X -> hs0,hs1,hs2,hs3 \ X' W Z -> xwy _\ via stxwx() in ./stxwx.f */ /* trevor fixed this 4/19/88 * Note: sbart, i.e. stxwx() and sslvrg() {mostly, not always!}, use * the square of the weights; the following rectifies that */ for (i = 0; i < *n; ++i) if (ws[i] > 0.) ws[i] = sqrt(ws[i]); if (*isetup < 0) spar_is_lambda = TRUE; else if (*isetup != 1) { // 0 or 2 /* SIGMA[i,j] := Int B''(i,t) B''(j,t) dt {B(k,.) = k-th B-spline} */ F77_CALL(sgram)(sg0, sg1, sg2, sg3, knot, nk); F77_CALL(stxwx)(xs, ys, ws, n, knot, nk, xwy, hs0, hs1, hs2, hs3); spar_is_lambda = (*isetup == 2); if(!spar_is_lambda) { /* Compute ratio := tr(X' W X) / tr(SIGMA) */ double t1 = 0., t2 = 0.; for (i = 3 - 1; i < (*nk - 3); ++i) { t1 += hs0[i]; t2 += sg0[i]; } ratio = t1 / t2; } *isetup = 1; } /* Compute estimate */ // Compute SSPLINE(SPAR), assign result to *crit (and the auxil.variables) #define SSPLINE_COMP(_SPAR_) \ *lspar = spar_is_lambda ? _SPAR_ \ : ratio * R_pow(16., (_SPAR_) * 6. - 2.); \ F77_CALL(sslvrg)(penalt, dofoff, xs, ys, ws, ssw, n, \ knot, nk, \ coef, sz, lev, crit, icrit, lspar, xwy, \ hs0, hs1, hs2, hs3, \ sg0, sg1, sg2, sg3, abd, \ p1ip, p2ip, ld4, ldnk, ier) if (*ispar == 1) { /* Value of spar supplied */ SSPLINE_COMP(*spar); /* got through check 2 */ *Ratio = ratio; return; } /* ELSE ---- spar not supplied --> compute it ! --------------------------- */ ax = *lspar; bx = *uspar; /* Use Forsythe Malcom and Moler routine to MINIMIZE criterion f denotes the value of the criterion an approximation x to the point where f attains a minimum on the interval (ax,bx) is determined. INPUT ax left endpoint of initial interval bx right endpoint of initial interval f function subprogram which evaluates f(x) for any x in the interval (ax,bx) tol desired length of the interval of uncertainty of the final result ( >= 0 ) OUTPUT fmin abcissa approximating the point where f attains a minimum */ /* The method used is a combination of golden section search and successive parabolic interpolation. convergence is never much slower than that for a fibonacci search. if f has a continuous second derivative which is positive at the minimum (which is not at ax or bx), then convergence is superlinear, and usually of the order of about 1.324.... the function f is never evaluated at two points closer together than eps*abs(fmin) + (tol/3), where eps is approximately the square root of the relative machine precision. if f is a unimodal function and the computed values of f are always unimodal when separated by at least eps*abs(x) + (tol/3), then fmin approximates the abcissa of the global minimum of f on the interval ax,bx with an error less than 3*eps*abs(fmin) + tol. if f is not unimodal, then fmin may approximate a local, but perhaps non-global, minimum to the same accuracy. this function subprogram is a slightly modified version of the algol 60 procedure localmin given in richard brent, algorithms for minimization without derivatives, prentice - hall, inc. (1973). Double a,b,c,d,e,eps,xm,p,q,r,tol1,tol2,u,v,w Double fu,fv,fw,fx,x */ /* eps is approximately the square root of the relative machine precision. - eps = 1e0 - 10 eps = eps/2e0 - tol1 = 1e0 + eps - if (tol1 > 1e0) go to 10 - eps = sqrt(eps) R Version <= 1.3.x had eps = .000244 ( = sqrt(5.954 e-8) ) -- now eps is passed as argument */ /* initialization */ maxit = *iter; *iter = 0; a = ax; b = bx; v = a + c_Gold * (b - a); w = v; x = v; e = 0.; SSPLINE_COMP(x); fx = *crit; fv = fx; fw = fx; /* main loop --------- */ while(*ier == 0) { /* L20: */ xm = (a + b) * .5; tol1 = *eps * fabs(x) + *tol / 3.; tol2 = tol1 * 2.; ++(*iter); if(tracing) { if(*iter == 1) {/* write header */ Rprintf("sbart (ratio = %15.8g) iterations;" " initial tol1 = %12.6e :\n" "%11s %14s %9s %11s Kind %11s %12s\n%s\n", ratio, tol1, "spar", ((*icrit == 1) ? "GCV" : (*icrit == 2) ? "CV" : (*icrit == 3) ?"(df0-df)^2" : /*else (should not happen) */"?f?"), "b - a", "e", "NEW lspar", "crit", " ---------------------------------------" "----------------------------------------"); } Rprintf("%11.8f %14.9g %9.4e %11.5g", x, CRIT(fx), b - a, e); Fparabol = FALSE; } /* Check the (somewhat peculiar) stopping criterion: note that the RHS is negative as long as the interval [a,b] is not small:*/ if (fabs(x - xm) <= tol2 - (b - a) * .5 || *iter > maxit) goto L_End; /* is golden-section necessary */ if (fabs(e) <= tol1 || /* if had Inf then go to golden-section */ fx >= BIG_f || fv >= BIG_f || fw >= BIG_f) goto L_GoldenSect; /* Fit Parabola */ if(tracing) { Rprintf(" FP"); Fparabol = TRUE; } r = (x - w) * (fx - fv); q = (x - v) * (fx - fw); p = (x - v) * q - (x - w) * r; q = (q - r) * 2.; if (q > 0.) p = -p; q = fabs(q); r = e; e = d; /* is parabola acceptable? Otherwise do golden-section */ if (fabs(p) >= fabs(.5 * q * r) || q == 0.) /* above line added by BDR; * [the abs(.) >= abs() = 0 should have branched..] * in FTN: COMMON above ensures q is NOT a register variable */ goto L_GoldenSect; if (p <= q * (a - x) || p >= q * (b - x)) goto L_GoldenSect; /* Parabolic Interpolation step */ if(tracing) Rprintf(" PI "); d = p / q; if(!R_FINITE(d)) REprintf(" !FIN(d:=p/q): ier=%d, (v,w, p,q)= %g, %g, %g, %g\n", *ier, v,w, p, q); u = x + d; /* f must not be evaluated too close to ax or bx */ if (u - a < tol2 || b - u < tol2) d = fsign(tol1, xm - x); goto L50; /*------*/ L_GoldenSect: /* a golden-section step */ if(tracing) Rprintf(" GS%s ", Fparabol ? "" : " --"); if (x >= xm) e = a - x; else/* x < xm*/ e = b - x; d = c_Gold * e; L50: u = x + ((fabs(d) >= tol1) ? d : fsign(tol1, d)); /* tol1 check : f must not be evaluated too close to x */ SSPLINE_COMP(u); fu = *crit; if(tracing) Rprintf("%11g %12g\n", *lspar, CRIT(fu)); if(!R_FINITE(fu)) { REprintf("spar-finding: non-finite value %g; using BIG value\n", fu); fu = 2. * BIG_f; } /* update a, b, v, w, and x */ if (fu <= fx) { if (u >= x) a = x; else b = x; v = w; fv = fw; w = x; fw = fx; x = u; fx = fu; } else { if (u < x) a = u; else b = u; if (fu <= fw || w == x) { /* L70: */ v = w; fv = fw; w = u; fw = fu; } else if (fu <= fv || v == x || v == w) { /* L80: */ v = u; fv = fu; } } }/* end main loop -- goto L20; */ L_End: if(tracing) Rprintf(" >>> %12g %12g\n", *lspar, CRIT(fx)); *Ratio = ratio; *spar = x; *crit = fx; return; } /* sbart */
/** * utility function to print out division lines */ static R_INLINE void print_line(){ Rprintf("-----------------------------------------\n"); }
void _computeItemTrace(vector<double> &itemtrace, const NumericMatrix &Theta, const List &pars, const NumericVector &ot, const vector<int> &itemloc, const int &which, const int &nfact, const int &N, const int &USEFIXED) { NumericMatrix theta = Theta; int nfact2 = nfact; S4 item = pars[which]; int ncat = as<int>(item.slot("ncat")); vector<double> par = as< vector<double> >(item.slot("par")); vector<double> P(N*ncat); int itemclass = as<int>(item.slot("itemclass")); int correct = 0; if(itemclass == 8) correct = as<int>(item.slot("correctcat")); /* 1 = dich 2 = graded 3 = gpcm 4 = nominal 5 = grsm 6 = rsm 7 = partcomp 8 = nestlogit 9 = custom....have to do in R for now */ if(USEFIXED){ NumericMatrix itemFD = item.slot("fixed.design"); nfact2 = nfact + itemFD.ncol(); NumericMatrix NewTheta(Theta.nrow(), nfact2); for(int i = 0; i < itemFD.ncol(); ++i) NewTheta(_,i) = itemFD(_,i); for(int i = 0; i < nfact; ++i) NewTheta(_,i+itemFD.ncol()) = Theta(_,i); theta = NewTheta; } switch(itemclass){ case 1 : P_dich(P, par, theta, ot, N, nfact2); break; case 2 : P_graded(P, par, theta, ot, N, nfact2, ncat-1, 1, 0); break; case 3 : P_nominal(P, par, theta, ot, N, nfact2, ncat, 0, 0); break; case 4 : P_nominal(P, par, theta, ot, N, nfact2, ncat, 0, 0); break; case 5 : P_graded(P, par, theta, ot, N, nfact2, ncat-1, 1, 1); break; case 6 : P_nominal(P, par, theta, ot, N, nfact2, ncat, 0, 1); break; case 7 : P_comp(P, par, theta, N, nfact2); break; case 8 : P_nested(P, par, theta, N, nfact2, ncat, correct); break; case 9 : break; default : Rprintf("How in the heck did you get here from a switch statement?\n"); break; } int where = (itemloc[which]-1) * N; for(int i = 0; i < N*ncat; ++i) itemtrace[where + i] = P[i]; }
void AllStatistics ( int *tails, int *heads, int *dnedges, int *dn, /* Number of nodes */ int *dflag, /* directed flag */ int *bipartite, int *nterms, char **funnames, char **sonames, double *inputs, double *covmat, int *weightsvector, int *maxNumDyadTypes) { Network *nwp; Vertex n_nodes = (Vertex) *dn; unsigned int directed_flag = *dflag; Vertex nodelistlength, rowmax, *nodelist1, *nodelist2; Vertex bip = (Vertex) *bipartite; Model *m; ModelTerm *mtp; /* Step 1: Initialize empty network and initialize model */ GetRNGstate(); /* Necessary for R random number generator */ nwp=NetworkInitialize((Vertex*)tails, (Vertex*)heads, *dnedges, n_nodes, directed_flag, bip, 0, 0, NULL); m=ModelInitialize(*funnames, *sonames, &inputs, *nterms); /* Step 2: Build nodelist1 and nodelist2, which together give all of the dyads in the network. */ if (BIPARTITE > 0) { /* Assuming undirected in the bipartite case */ nodelistlength = BIPARTITE * (N_NODES-BIPARTITE); rowmax = BIPARTITE + 1; } else { nodelistlength = N_NODES * (N_NODES-1) / (DIRECTED? 1 : 2); rowmax = N_NODES; } nodelist1 = (Vertex *) R_alloc(nodelistlength, sizeof(int)); nodelist2 = (Vertex *) R_alloc(nodelistlength, sizeof(int)); int count = 0; for(int i=1; i < rowmax; i++) { for(int j = MAX(i,BIPARTITE)+1; j <= N_NODES; j++) { for(int d=0; d <= DIRECTED; d++) { /*trivial loop if undirected*/ nodelist1[count] = d==1? j : i; nodelist2[count] = d==1? i : j; count++; } } } /* Step 3: Initialize values of mtp->dstats so they point to the correct spots in the newRow vector. These values will never change. */ double *changeStats = (double *) R_alloc(m->n_stats,sizeof(double)); double *cumulativeStats = (double *) R_alloc(m->n_stats,sizeof(double)); for (int i=0; i < m->n_stats; i++) cumulativeStats[i]=0.0; unsigned int totalStats = 0; for (mtp=m->termarray; mtp < m->termarray + m->n_terms; mtp++){ mtp->dstats = changeStats + totalStats; /* Update mtp->dstats pointer to skip atail by mtp->nstats */ totalStats += mtp->nstats; } if (totalStats != m->n_stats) { Rprintf("I thought totalStats=%d and m->nstats=%d should be the same.\n", totalStats, m->n_stats); } /* Step 4: Begin recursion */ RecurseOffOn(nodelist1, nodelist2, nodelistlength, 0, changeStats, cumulativeStats, covmat, (unsigned int*) weightsvector, *maxNumDyadTypes, nwp, m); /* Step 5: Deallocate memory and return */ ModelDestroy(m); NetworkDestroy(nwp); PutRNGstate(); /* Must be called after GetRNGstate before returning to R */ }
SEXP amcmc(SEXP Y, SEXP X, SEXP Rweights, SEXP Rprobinit, SEXP Rmodeldim, SEXP incint, SEXP Ralpha,SEXP method, SEXP modelprior, SEXP Rupdate, SEXP Rbestmodel, SEXP plocal, SEXP BURNIN_Iterations, SEXP MCMC_Iterations, SEXP LAMBDA, SEXP DELTA) { SEXP Rse_m, Rcoef_m, Rmodel_m; SEXP RXwork = PROTECT(duplicate(X)), RYwork = PROTECT(duplicate(Y)); int nProtected = 2, nUnique=0, newmodel=0; int nModels=LENGTH(Rmodeldim); // Rprintf("Allocating Space for %d Models\n", nModels) ; SEXP ANS = PROTECT(allocVector(VECSXP, 15)); ++nProtected; SEXP ANS_names = PROTECT(allocVector(STRSXP, 15)); ++nProtected; SEXP Rprobs = PROTECT(duplicate(Rprobinit)); ++nProtected; SEXP MCMCprobs= PROTECT(duplicate(Rprobinit)); ++nProtected; SEXP R2 = PROTECT(allocVector(REALSXP, nModels)); ++nProtected; SEXP shrinkage = PROTECT(allocVector(REALSXP, nModels)); ++nProtected; SEXP modelspace = PROTECT(allocVector(VECSXP, nModels)); ++nProtected; SEXP modeldim = PROTECT(duplicate(Rmodeldim)); ++nProtected; SEXP counts = PROTECT(duplicate(Rmodeldim)); ++nProtected; SEXP beta = PROTECT(allocVector(VECSXP, nModels)); ++nProtected; SEXP se = PROTECT(allocVector(VECSXP, nModels)); ++nProtected; SEXP mse = PROTECT(allocVector(REALSXP, nModels)); ++nProtected; SEXP modelprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected; SEXP priorprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected; SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected; SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected; SEXP NumUnique = PROTECT(allocVector(INTSXP, 1)); ++nProtected; double *Xwork, *Ywork, *wts, *coefficients,*probs, shrinkage_m, *MCMC_probs, SSY, yty, mse_m, *se_m, MH=0.0, prior_m=1.0, *real_model, prob_i, R2_m, RSquareFull, alpha, prone, denom, logmargy, postold, postnew; int nobs, p, k, i, j, m, n, l, pmodel, pmodel_old, *xdims, *model_m, *bestmodel, *varin, *varout; int mcurrent, update, n_sure; double mod, rem, problocal, *pigamma, pigammaold, pigammanew, eps, *hyper_parameters; double *XtX, *XtY, *XtXwork, *XtYwork, *SSgam, *Cov, *priorCov, *marg_probs; double one=1.0, lambda, delta, wt = 1.0; int inc=1, print = 0; int *model, *modelold, bit, *modelwork, old_loc, new_loc; struct Var *vars; /* Info about the model variables. */ NODEPTR tree, branch; /* get dimsensions of all variables */ nobs = LENGTH(Y); xdims = INTEGER(getAttrib(X,R_DimSymbol)); p = xdims[1]; k = LENGTH(modelprobs); update = INTEGER(Rupdate)[0]; lambda=REAL(LAMBDA)[0]; delta = REAL(DELTA)[0]; // Rprintf("delta %f lambda %f", delta, lambda); eps = DBL_EPSILON; problocal = REAL(plocal)[0]; // Rprintf("Update %i and prob.switch %f\n", update, problocal); /* Extract prior on models */ hyper_parameters = REAL(getListElement(modelprior,"hyper.parameters")); /* Rprintf("n %d p %d \n", nobs, p); */ Ywork = REAL(RYwork); Xwork = REAL(RXwork); wts = REAL(Rweights); PrecomputeData(Xwork, Ywork, wts, &XtXwork, &XtYwork, &XtX, &XtY, &yty, &SSY, p, nobs); alpha = REAL(Ralpha)[0]; vars = (struct Var *) R_alloc(p, sizeof(struct Var)); probs = REAL(Rprobs); n = sortvars(vars, probs, p); for (i =0; i <n; i++) REAL(MCMCprobs)[vars[i].index] = 0.0; MCMC_probs = REAL(MCMCprobs); pigamma = vecalloc(p); real_model = vecalloc(n); marg_probs = vecalloc(n); modelold = ivecalloc(p); model = ivecalloc(p); modelwork= ivecalloc(p); varin= ivecalloc(p); varout= ivecalloc(p); /* create gamma gamma' matrix */ SSgam = (double *) R_alloc(n * n, sizeof(double)); Cov = (double *) R_alloc(n * n, sizeof(double)); priorCov = (double *) R_alloc(n * n, sizeof(double)); for (j=0; j < n; j++) { for (i = 0; i < n; i++) { SSgam[j*n + i] = 0.0; Cov[j*n + i] = 0.0; priorCov[j*n + i] = 0.0; if (j == i) priorCov[j*n + i] = lambda; } marg_probs[i] = 0.0; } /* Make space for the models and working variables. */ /* pivot = ivecalloc(p); qraux = vecalloc(p); work = vecalloc(2 * p); effects = vecalloc(nobs); v = vecalloc(p * p); betaols = vecalloc(p); */ /* Rprintf("Fit Full Model\n"); */ if (nobs <= p) {RSquareFull = 1.0;} else { PROTECT(Rcoef_m = NEW_NUMERIC(p)); PROTECT(Rse_m = NEW_NUMERIC(p)); coefficients = REAL(Rcoef_m); se_m = REAL(Rse_m); memcpy(coefficients, XtY, p*sizeof(double)); memcpy(XtXwork, XtX, p*p*sizeof(double)); memcpy(XtYwork, XtY, p*sizeof(double)); mse_m = yty; cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, p, nobs); /*olsreg(Ywork, Xwork, coefficients, se_m, &mse_m, &p, &nobs, pivot,qraux,work,residuals,effects,v, betaols); */ RSquareFull = 1.0 - (mse_m * (double) ( nobs - p))/SSY; UNPROTECT(2); } /* fill in the sure things */ for (i = n, n_sure = 0; i < p; i++) { model[vars[i].index] = (int) vars[i].prob; if (model[vars[i].index] == 1) ++n_sure; } GetRNGstate(); tree = make_node(-1.0); /* Rprintf("For m=0, Initialize Tree with initial Model\n"); */ m = 0; bestmodel = INTEGER(Rbestmodel); INTEGER(modeldim)[m] = n_sure; /* Rprintf("Create Tree\n"); */ branch = tree; for (i = 0; i< n; i++) { bit = bestmodel[vars[i].index]; if (bit == 1) { if (i < n-1 && branch->one == NULL) branch->one = make_node(-1.0); if (i == n-1 && branch->one == NULL) branch->one = make_node(0.0); branch = branch->one; } else { if (i < n-1 && branch->zero == NULL) branch->zero = make_node(-1.0); if (i == n-1 && branch->zero == NULL) branch->zero = make_node(0.0); branch = branch->zero; } model[vars[i].index] = bit; INTEGER(modeldim)[m] += bit; branch->where = 0; } /* Rprintf("Now get model specific calculations \n"); */ pmodel = INTEGER(modeldim)[m]; PROTECT(Rmodel_m = allocVector(INTSXP,pmodel)); model_m = INTEGER(Rmodel_m); for (j = 0, l=0; j < p; j++) { if (model[j] == 1) { model_m[l] = j; l +=1;} } SET_ELEMENT(modelspace, m, Rmodel_m); Rcoef_m = NEW_NUMERIC(pmodel); PROTECT(Rcoef_m); Rse_m = NEW_NUMERIC(pmodel); PROTECT(Rse_m); coefficients = REAL(Rcoef_m); se_m = REAL(Rse_m); for (j=0, l=0; j < pmodel; j++) { XtYwork[j] = XtY[model_m[j]]; for ( i = 0; i < pmodel; i++) { XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]]; } } mse_m = yty; memcpy(coefficients, XtYwork, sizeof(double)*pmodel); cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs); R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY; SET_ELEMENT(beta, m, Rcoef_m); SET_ELEMENT(se, m, Rse_m); REAL(R2)[m] = R2_m; REAL(mse)[m] = mse_m; gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m); REAL(sampleprobs)[m] = 1.0; REAL(logmarg)[m] = logmargy; REAL(shrinkage)[m] = shrinkage_m; prior_m = compute_prior_probs(model,pmodel,p, modelprior); REAL(priorprobs)[m] = prior_m; UNPROTECT(3); old_loc = 0; pmodel_old = pmodel; nUnique=1; INTEGER(counts)[0] = 0; postold = REAL(logmarg)[m] + log(REAL(priorprobs)[m]); memcpy(modelold, model, sizeof(int)*p); /* Rprintf("model %d max logmarg %lf\n", m, REAL(logmarg)[m]); */ /* Rprintf("Now Sample the Rest of the Models \n"); */ m = 0; // Need to fix in case the number of sampled models exceeds the space! while (m < INTEGER(BURNIN_Iterations)[0]) { memcpy(model, modelold, sizeof(int)*p); pmodel = n_sure; MH = 1.0; if (pmodel_old == n_sure || pmodel_old == n_sure + n){ MH = random_walk(model, vars, n); MH = 1.0 - problocal; } else { if (unif_rand() < problocal) { // random MH = random_switch(model, vars, n, pmodel_old, varin, varout ); } else { // Randomw walk proposal flip bit// MH = random_walk(model, vars, n); } } branch = tree; newmodel= 0; for (i = 0; i< n; i++) { bit = model[vars[i].index]; if (bit == 1) { if (branch->one != NULL) branch = branch->one; else newmodel = 1; } else { if (branch->zero != NULL) branch = branch->zero; else newmodel = 1.0; } pmodel += bit; } if (pmodel == n_sure || pmodel == n + n_sure) MH = 1.0/(1.0 - problocal); if (newmodel == 1) { new_loc = nUnique; PROTECT(Rmodel_m = allocVector(INTSXP,pmodel)); model_m = INTEGER(Rmodel_m); for (j = 0, l=0; j < p; j++) { if (model[j] == 1) { model_m[l] = j; l +=1;} } Rcoef_m = NEW_NUMERIC(pmodel); PROTECT(Rcoef_m); Rse_m = NEW_NUMERIC(pmodel); PROTECT(Rse_m); coefficients = REAL(Rcoef_m); se_m = REAL(Rse_m); for (j=0, l=0; j < pmodel; j++) { XtYwork[j] = XtY[model_m[j]]; for ( i = 0; i < pmodel; i++) { XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]]; } } mse_m = yty; memcpy(coefficients, XtYwork, sizeof(double)*pmodel); cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs); R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY; prior_m = compute_prior_probs(model,pmodel,p, modelprior); gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m); postnew = logmargy + log(prior_m); } else { new_loc = branch->where; postnew = REAL(logmarg)[new_loc] + log(REAL(priorprobs)[new_loc]); } MH *= exp(postnew - postold); // Rprintf("MH new %lf old %lf\n", postnew, postold); if (unif_rand() < MH) { if (newmodel == 1) { new_loc = nUnique; insert_model_tree(tree, vars, n, model, nUnique); INTEGER(modeldim)[nUnique] = pmodel; SET_ELEMENT(modelspace, nUnique, Rmodel_m); SET_ELEMENT(beta, nUnique, Rcoef_m); SET_ELEMENT(se, nUnique, Rse_m); REAL(R2)[nUnique] = R2_m; REAL(mse)[nUnique] = mse_m; REAL(sampleprobs)[nUnique] = 1.0; REAL(logmarg)[nUnique] = logmargy; REAL(shrinkage)[nUnique] = shrinkage_m; REAL(priorprobs)[nUnique] = prior_m; UNPROTECT(3); ++nUnique; } old_loc = new_loc; postold = postnew; pmodel_old = pmodel; memcpy(modelold, model, sizeof(int)*p); } else { if (newmodel == 1) UNPROTECT(3); } INTEGER(counts)[old_loc] += 1; for (i = 0; i < n; i++) { real_model[i] = (double) modelold[vars[i].index]; REAL(MCMCprobs)[vars[i].index] += (double) modelold[vars[i].index]; } // Update SSgam = gamma gamma^T + SSgam F77_NAME(dsyr)("U", &n, &one, &real_model[0], &inc, &SSgam[0], &n); m++; } // Rprintf("\n%d Unique models sampled during burnin\n", nUnique); // Compute marginal probabilities mcurrent = nUnique; compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent); compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p); for (i = 0; i < n; i++) { marg_probs[i] = wt*(REAL(MCMCprobs)[vars[i].index]/ (double) m) + (1.0 - wt)* probs[vars[i].index]; } // print=1; update_Cov(Cov, priorCov, SSgam, marg_probs, n, m, print); // Global-Proposal // Initialize post old proposal pigammaold = 0.0; for (i = 0; i < n; i++) { if (modelold[vars[i].index] == 1 ){ real_model[i] = 1.0; pigammaold += log(cond_prob(real_model,i, n, marg_probs,Cov, delta)); } else { real_model[i] = 0.0; pigammaold += log(1.0 - cond_prob(real_model,i, n, marg_probs,Cov, delta)); } } // need to fix to make sure that nUnique is less than nModels while (m < INTEGER(BURNIN_Iterations)[0] + INTEGER(MCMC_Iterations)[0]) { // for (m = 0; m < k; m++) { memcpy(model, modelold, sizeof(int)*p); pmodel = n_sure; MH = 1.0; pigammanew = 0.0; branch = tree; newmodel = 0; for (i = 0; i < n; i++) { prob_i = cond_prob(real_model,i, n, marg_probs,Cov,delta); bit = withprob(prob_i); if (bit == 1) { pigammanew += log(prob_i); if (branch->one != NULL) branch = branch->one; else newmodel= 1; } else { pigammanew += log(1.0 - prob_i); if (branch->zero != NULL) branch = branch->zero; else newmodel= 1; } model[vars[i].index] = bit; real_model[i] = (double) bit; pmodel += bit; } if (newmodel == 1) { new_loc = nUnique; PROTECT(Rmodel_m = allocVector(INTSXP,pmodel)); model_m = INTEGER(Rmodel_m); for (j = 0, l=0; j < p; j++) { if (model[j] == 1) { model_m[l] = j; l +=1;} } Rcoef_m = NEW_NUMERIC(pmodel); PROTECT(Rcoef_m); Rse_m = NEW_NUMERIC(pmodel); PROTECT(Rse_m); coefficients = REAL(Rcoef_m); se_m = REAL(Rse_m); for (j=0, l=0; j < pmodel; j++) { XtYwork[j] = XtY[model_m[j]]; for ( i = 0; i < pmodel; i++) { XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]]; } } mse_m = yty; memcpy(coefficients, XtYwork, sizeof(double)*pmodel); cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs); R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY; prior_m = compute_prior_probs(model,pmodel,p, modelprior); gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m); postnew = logmargy + log(prior_m); } else { new_loc = branch->where; postnew = REAL(logmarg)[new_loc] + log(REAL(priorprobs)[new_loc]); } MH = exp(postnew - postold + pigammaold - pigammanew); // Rprintf("it %d MH %lf new %lf old %lf propold %lf propnew %lf \n", m, MH, postnew, postold, pigammanew, pigammaold); if (unif_rand() < MH) { if (newmodel ==1) { new_loc = nUnique; insert_model_tree(tree, vars, n, model, nUnique); INTEGER(modeldim)[nUnique] = pmodel; SET_ELEMENT(modelspace, nUnique, Rmodel_m); SET_ELEMENT(beta, nUnique, Rcoef_m); SET_ELEMENT(se, nUnique, Rse_m); REAL(R2)[nUnique] = R2_m; REAL(mse)[nUnique] = mse_m; REAL(logmarg)[nUnique] = logmargy; REAL(shrinkage)[nUnique] = shrinkage_m; REAL(priorprobs)[nUnique] = prior_m; UNPROTECT(3); ++nUnique; } old_loc = new_loc; pigammaold = pigammanew; REAL(sampleprobs)[old_loc] = pigammaold; postold = postnew; pmodel_old = pmodel; memcpy(modelold, model, sizeof(int)*p); } else { if (newmodel == 1) UNPROTECT(3); } INTEGER(counts)[old_loc] += 1; for (i = 0; i < n; i++) { real_model[i] = (double) modelold[vars[i].index]; REAL(MCMCprobs)[vars[i].index] += (double) modelold[vars[i].index]; } F77_NAME(dsyr)("U", &n, &one, &real_model[0], &inc, &SSgam[0], &n); m++; rem = modf((double) m/(double) update, &mod); if (rem == 0.0) { mcurrent = nUnique; compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent); compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p); for (i = 0; i < n; i++) { marg_probs[i] = wt*(REAL(MCMCprobs)[vars[i].index]/ (double) m) + (1.0 - wt)*probs[vars[i].index]; } update_Cov(Cov, priorCov, SSgam, marg_probs, n, m, print); // Initialize post old proposal pigammaold = 0.0; for (i = 0; i < n; i++) { if (modelold[vars[i].index] == 1 ){ real_model[i] = 1.0; pigammaold += log(cond_prob(real_model,i, n, marg_probs,Cov, delta)); } else { real_model[i] = 0.0; pigammaold += log(1.0 - cond_prob(real_model,i, n, marg_probs,Cov, delta)); }} } } mcurrent = nUnique; compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent); compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p); wt = 0.1; for (i = 0; i < n; i++) { marg_probs[i] = wt* (REAL(MCMCprobs)[vars[i].index]/ (double) m) + (1.0 - wt)*probs[vars[i].index]; // marg_probs[n-1-i] = REAL(MCMCprobs)[vars[i].index]/ (double) m; REAL(MCMCprobs)[vars[i].index] /= (double) m; } update_Cov(Cov, priorCov, SSgam, marg_probs, n, m, print); // Now sample W/O Replacement // Rprintf("NumUnique Models Accepted %d \n", nUnique); INTEGER(NumUnique)[0] = nUnique; if (nUnique < k) { // compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent); // compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p); // update_MCMC_probs(MCMC_probs, vars, n, p); // Rprintf("Update Tree\n"); update_cond_tree(modelspace, tree, modeldim, vars, p, n, nUnique, modelwork, real_model, marg_probs, Cov, eps); // Rprintf("\nNow sample the rest without replacement\n"); for (m = nUnique; m < k; m++) { INTEGER(modeldim)[m] = n_sure; branch = tree; for (i = 0; i< n; i++) { pigamma[i] = 1.0; if (branch->prob == -1.0) { branch->prob = cond_prob(real_model,i, n, marg_probs,Cov, delta); branch->update = m+mcurrent; } bit = withprob(branch->prob); real_model[n-i-1] = (double) bit; if (bit == 1) { for (j=0; j<=i; j++) pigamma[j] *= branch->prob; if (i < n-1 && branch->one == NULL) // branch->one = make_node(vars[i+1].prob); branch->one = make_node(cond_prob(real_model,i+1, n, marg_probs,Cov , delta)); if (i == n-1 && branch->one == NULL) branch->one = make_node(0.0); branch = branch->one; } else { for (j=0; j<=i; j++) pigamma[j] *= (1.0 - branch->prob); if (i < n-1 && branch->zero == NULL) // branch->zero = make_node(vars[i+1].prob); branch->zero = make_node(cond_prob(real_model,i+1, n, marg_probs,Cov, delta)); if (i == n-1 && branch->zero == NULL) branch->zero = make_node(0.0); branch = branch->zero; } model[vars[i].index] = bit; INTEGER(modeldim)[m] += bit; } REAL(sampleprobs)[m] = pigamma[0]; pmodel = INTEGER(modeldim)[m]; // Now subtract off the visited probability mass. branch=tree; for (i = 0; i < n; i++) { bit = model[vars[i].index]; prone = branch->prob; if (bit == 1) prone -= pigamma[i]; denom = 1.0 - pigamma[i]; if (denom <= 0.0) { if (denom < 0.0) { Rprintf("neg denominator %le %le %le !!!\n", pigamma, denom, prone); if (branch->prob < 0.0 && branch->prob < 1.0) Rprintf("non extreme %le\n", branch->prob);} denom = 0.0;} else { if (prone <= 0) prone = 0.0; if (prone > denom) { if (prone <= eps) prone = 0.0; else prone = 1.0; // Rprintf("prone > 1 %le %le %le %le !!!\n", pigamma, denom, prone, eps); } else prone = prone/denom; } if (prone > 1.0 || prone < 0.0) Rprintf("%d %d Probability > 1!!! %le %le %le %le \n", m, i, prone, branch->prob, denom, pigamma); // if (bit == 1) pigamma /= (branch->prob); // else pigamma /= (1.0 - branch->prob); // if (pigamma > 1.0) pigamma = 1.0; branch->prob = prone; if (bit == 1) branch = branch->one; else branch = branch->zero; // Rprintf("%d %d \n", branch->done, n - i); // if (log((double) branch->done) < (n - i)*log(2.0)) { // if (bit == 1) branch = branch->one; // else branch = branch->zero; //} //else { // branch->one = NULL; // branch->zero = NULL; // break; } } /* Now get model specific calculations */ PROTECT(Rmodel_m = allocVector(INTSXP, pmodel)); model_m = INTEGER(Rmodel_m); for (j = 0, l=0; j < p; j++) { if (model[j] == 1) { model_m[l] = j; l +=1;} } SET_ELEMENT(modelspace, m, Rmodel_m); for (j=0, l=0; j < pmodel; j++) { XtYwork[j] = XtY[model_m[j]]; for ( i = 0; i < pmodel; i++) { XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]]; } } PROTECT(Rcoef_m = allocVector(REALSXP,pmodel)); PROTECT(Rse_m = allocVector(REALSXP,pmodel)); coefficients = REAL(Rcoef_m); se_m = REAL(Rse_m); mse_m = yty; memcpy(coefficients, XtYwork, sizeof(double)*pmodel); cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs); // olsreg(Ywork, Xwork, coefficients, se_m, &mse_m, &pmodel, &nobs, pivot,qraux,work,residuals,effects,v,betaols); R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY; SET_ELEMENT(beta, m, Rcoef_m); SET_ELEMENT(se, m, Rse_m); REAL(R2)[m] = R2_m; REAL(mse)[m] = mse_m; gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m); REAL(logmarg)[m] = logmargy; REAL(shrinkage)[m] = shrinkage_m; REAL(priorprobs)[m] = compute_prior_probs(model,pmodel,p, modelprior); UNPROTECT(3); } } // Rprintf("modelprobs\n"); compute_modelprobs(modelprobs, logmarg, priorprobs,k); // Rprintf("marginal probs\n"); compute_margprobs(modelspace, modeldim, modelprobs, probs, k, p); // Rprintf("saving\n"); SET_VECTOR_ELT(ANS, 0, Rprobs); SET_STRING_ELT(ANS_names, 0, mkChar("probne0")); SET_VECTOR_ELT(ANS, 1, modelspace); SET_STRING_ELT(ANS_names, 1, mkChar("which")); SET_VECTOR_ELT(ANS, 2, logmarg); SET_STRING_ELT(ANS_names, 2, mkChar("logmarg")); SET_VECTOR_ELT(ANS, 3, modelprobs); SET_STRING_ELT(ANS_names, 3, mkChar("postprobs")); SET_VECTOR_ELT(ANS, 4, priorprobs); SET_STRING_ELT(ANS_names, 4, mkChar("priorprobs")); SET_VECTOR_ELT(ANS, 5,sampleprobs); SET_STRING_ELT(ANS_names, 5, mkChar("sampleprobs")); SET_VECTOR_ELT(ANS, 6, mse); SET_STRING_ELT(ANS_names, 6, mkChar("mse")); SET_VECTOR_ELT(ANS, 7, beta); SET_STRING_ELT(ANS_names, 7, mkChar("mle")); SET_VECTOR_ELT(ANS, 8, se); SET_STRING_ELT(ANS_names, 8, mkChar("mle.se")); SET_VECTOR_ELT(ANS, 9, shrinkage); SET_STRING_ELT(ANS_names, 9, mkChar("shrinkage")); SET_VECTOR_ELT(ANS, 10, modeldim); SET_STRING_ELT(ANS_names, 10, mkChar("size")); SET_VECTOR_ELT(ANS, 11, R2); SET_STRING_ELT(ANS_names, 11, mkChar("R2")); SET_VECTOR_ELT(ANS, 12, counts); SET_STRING_ELT(ANS_names, 12, mkChar("freq")); SET_VECTOR_ELT(ANS, 13, MCMCprobs); SET_STRING_ELT(ANS_names, 13, mkChar("probs.MCMC")); SET_VECTOR_ELT(ANS, 14, NumUnique); SET_STRING_ELT(ANS_names, 14, mkChar("n.Unique")); setAttrib(ANS, R_NamesSymbol, ANS_names); UNPROTECT(nProtected); // Rprintf("Return\n"); PutRNGstate(); return(ANS); }
void F77_SUB(rprintfi1)(char* msg, int *i) { Rprintf(msg, *i); Rprintf("\n"); }
void F77_SUB(rprintfi2)(char* msg, int *i1, int *i2) { Rprintf(msg, *i1, *i2); Rprintf("\n"); }
void F77_SUB(rprintfd1)(char* msg, double *d) { Rprintf(msg, *d); Rprintf("\n"); }
void F77_SUB(rprintfd2)(char* msg, double *d1, double *d2) { Rprintf(msg, *d1, *d2); Rprintf("\n"); }
void F77_SUB(rprintfdid)(char* msg, double *d1, int *i, double *d2) { Rprintf(msg, *d1, *i, *d2); Rprintf("\n"); }
void F77_SUB(rprintfdi)(char* msg, double *d, int *i) { Rprintf(msg, *d, *i); Rprintf("\n"); }
void F77_SUB(rprintfid)(char* msg, int *i, double *d) { Rprintf(msg, *i, *d); Rprintf("\n"); }
void R_test_call(DllInfo *info) { /* Register routines, allocate resources. */ Rprintf("test_call DLL loaded\n"); }
void F77_SUB(rprintfi3)(char* msg, int *i1, int *i2, int* i3) { Rprintf(msg, *i1, *i2, *i3); Rprintf("\n"); }
void R_unload_test_call(DllInfo *info) { /* Release resources. */ Rprintf("test_call DLL unloaded\n"); }
// may be redundant void F77_SUB(rprintf2)(char* msg) { Rprintf(msg); Rprintf("\n"); }
SEXP call_stsparse(SEXP y, SEXP time, SEXP func, SEXP parms, SEXP forcs, SEXP chtol, SEXP atol, SEXP rtol, SEXP itol, SEXP rho, SEXP initfunc, SEXP initforc, SEXP verbose, SEXP NNZ, SEXP NSP, SEXP NGP, SEXP nIter, SEXP Posit, SEXP Pos, SEXP nOut, SEXP Rpar, SEXP Ipar, SEXP Type, SEXP Ian, SEXP Jan, SEXP Met, SEXP Option) { SEXP yout, RWORK, IWORK; int j, k, ny, maxit, isSteady, method, lenplufac, lenplumx, lfill; double *svar, *dsvar, *beta, *alpha, tin, *Atol, *Rtol, Chtol; double *x, *precis, *ewt, droptol, permtol; int neq, nnz, nsp, ngp, niter, mflag, posit, TotN, ipos, Itol, type; int *ian, *jan, *igp, *jgp, *dims, *pos; int len, isDll, ilumethod; double *rsp= NULL, *plu= NULL, *rwork= NULL; int *R= NULL, *C= NULL, *IC= NULL, *indDIM = NULL; int *isp= NULL, *iwork= NULL, *iperm= NULL, *jlu= NULL, *ju= NULL; C_deriv_func_type *derivs; init_N_Protect(); nnz = INTEGER(NNZ)[0]; nsp = INTEGER(NSP)[0]; ngp = INTEGER(NGP)[0]; ny = LENGTH(y); Itol = INTEGER(itol)[0]; maxit = INTEGER(nIter)[0]; type = INTEGER(Type)[0]; method = INTEGER(Met)[0]; posit = INTEGER(Posit)[0]; /* positivity of state variables: either specified at once, or via a vector..*/ ipos = LENGTH(Pos); pos = (int *) R_alloc(ipos, sizeof(int)); for (j = 0; j < ipos; j++) pos[j] = INTEGER(Pos)[j]; neq = ny; mflag = INTEGER(verbose)[0]; if (inherits(func, "NativeSymbol")) /* function is a dll */ isDll = 1; else isDll = 0; if (nout > 0) isOut = 1; /* initialise output ... */ initOut(isDll, neq, nOut, Rpar, Ipar); /* initialise global variables... */ PROTECT(Time = NEW_NUMERIC(1)) ;incr_N_Protect(); PROTECT(Y = allocVector(REALSXP, neq)) ;incr_N_Protect(); /* copies of all variables that will be changed in the FORTRAN subroutine */ if (method == 1) { /* yale sparse matrix solver */ R = (int *) R_alloc(neq, sizeof(int)); for (j = 0; j < ny; j++) R[j] = 0; C = (int *) R_alloc(neq, sizeof(int)); for (j = 0; j < ny; j++) C[j] = 0; IC = (int *) R_alloc(neq, sizeof(int)); for (j = 0; j < ny; j++) IC[j] = 0; rsp = (double *) R_alloc(nsp, sizeof(double)); for (j = 0; j < nsp; j++) rsp[j] = 0.; isp = (int *) R_alloc(2*nsp, sizeof(int)); for (j = 0; j < 2*nsp; j++) isp[j] = 0; } else { /* sparskit matrix solver */ /* get options */ lenplufac = INTEGER(getListElement(Option, "lenplufac"))[0]; lfill = INTEGER(getListElement(Option, "fillin") )[0]; droptol = REAL (getListElement(Option, "droptol") )[0]; permtol = REAL (getListElement(Option, "permtol") )[0]; ilumethod = method - 1; /* 1 = ilut, 2 = ilutp */ lenplumx = nnz + lenplufac*neq; jlu = (int *) R_alloc(lenplumx, sizeof(int)); for (j = 0; j < lenplumx; j++) jlu[j] = 0; ju = (int *) R_alloc(neq, sizeof(int)); for (j = 0; j < neq; j++) ju[j] = 0; iwork = (int *) R_alloc(2*neq, sizeof(int)); for (j = 0; j < 2*neq; j++) iwork[j] = 0; iperm = (int *) R_alloc(2*neq, sizeof(int)); for (j = 0; j < 2*neq; j++) iperm[j] = 0; plu = (double *) R_alloc(lenplumx, sizeof(double)); for (j = 0; j < lenplumx; j++) plu[j] = 0.; rwork = (double *) R_alloc(neq, sizeof(double)); for (j = 0; j < neq; j++) rwork[j] = 0.; } dims = (int *) R_alloc(7, sizeof(int)); /* 7 is maximal amount */ for (j = 0; j < 7; j++) dims[j] = 0; svar = (double *) R_alloc(neq, sizeof(double)); for (j = 0; j < ny; j++) svar[j] = REAL(y)[j]; dsvar = (double *) R_alloc(neq, sizeof(double)); for (j = 0; j < ny; j++) dsvar[j] = 0; beta = (double *) R_alloc(neq, sizeof(double)); for (j = 0; j < ny; j++) beta[j] = 0; x = (double *) R_alloc(neq, sizeof(double)); for (j = 0; j < ny; j++) x[j] = 0; alpha = (double *) R_alloc(nnz, sizeof(double)); for (j = 0; j < nnz; j++) alpha[j] = 0; ewt = (double *) R_alloc(neq, sizeof(double)); for (j = 0; j < ny; j++) ewt[j] = 0; ian = (int *) R_alloc(neq+1, sizeof(int)); if (type == 0) {for (j = 0; j < neq; j++) ian[j] = INTEGER(Ian)[j];} else {for (j = 0; j < neq; j++) ian[j] = 0;} jan = (int *) R_alloc(nnz, sizeof(int)); if (type == 0) {for (j = 0; j < nnz; j++) jan[j] = INTEGER(Jan)[j];} else {for (j = 0; j < nnz; j++) jan[j] = 0;} /* 1-D, 2-D, 3-D problem: */ if (type == 2) /* 1=ncomp,2:dim(x), 3: cyclic(x)*/ for (j = 0; j<3 ; j++) dims[j] = INTEGER(NNZ)[j+1]; else if (type == 3) /* 1=ncomp,2-3:dim(x,y), 4-5: cyclic(x,y)*/ for (j = 0; j<5 ; j++) dims[j] = INTEGER(NNZ)[j+1]; else if (type == 4) /* 1=ncomp,2-4:dim(x,y,z), 5-7: cyclic(x,y,z)*/ for (j = 0; j<7 ; j++) dims[j] = INTEGER(NNZ)[j+1]; else if (type == 30) { /* same as type 3 (2-D) but with mapping */ for (j = 0; j<5 ; j++) dims[j] = INTEGER(NNZ)[j+1]; TotN = INTEGER(NNZ)[6]; indDIM = (int *) R_alloc(TotN, sizeof(int)); for (j = 0; j < TotN ; j++) indDIM[j] = INTEGER(NNZ)[j+7]; } else if (type == 40) { /* same as type 4 (3-D) but with mapping */ for (j = 0; j<7 ; j++) dims[j] = INTEGER(NNZ)[j+1]; TotN = INTEGER(NNZ)[8]; indDIM = (int *) R_alloc(TotN, sizeof(int)); for (j = 0; j < TotN ; j++) indDIM[j] = INTEGER(NNZ)[j+9]; } igp = (int *) R_alloc(ngp+1, sizeof(int)); for (j = 0; j < ngp+1; j++) igp[j] = 0; jgp = (int *) R_alloc(neq, sizeof(int)); for (j = 0; j < neq; j++) jgp[j] = 0; len = LENGTH(atol); Atol = (double *) R_alloc(len, sizeof(double)); for (j = 0; j < len; j++) Atol[j] = REAL(atol)[j]; len = LENGTH(rtol); Rtol = (double *) R_alloc(len, sizeof(double)); for (j = 0; j < len; j++) Rtol[j] = REAL(rtol)[j]; Chtol = REAL(chtol)[0]; precis =(double *) R_alloc(maxit, sizeof(double)); for (j = 0; j < maxit; j++) precis[j] = 0; PROTECT(yout = allocVector(REALSXP,ntot)) ; incr_N_Protect(); /* The initialisation routine */ initParms(initfunc, parms); initForcs(initforc, forcs); /* pointers to functions derivs and jac, passed to the FORTRAN subroutine */ if (isDll) { derivs = (C_deriv_func_type *) R_ExternalPtrAddrFn_(func); } else { derivs = (C_deriv_func_type *) C_stsparse_derivs; PROTECT(stsparse_deriv_func = func); incr_N_Protect(); PROTECT(stsparse_envir = rho);incr_N_Protect(); } tin = REAL(time)[0]; if (method == 1) { F77_CALL(dsparse) (derivs, &neq, &nnz, &nsp, &tin, svar, dsvar, beta, x, alpha, ewt, rsp, ian, jan, igp, jgp, &ngp, R, C, IC, isp, &maxit, &Chtol, Atol, Rtol, &Itol, &posit, pos, &ipos, &isSteady, precis, &niter, dims, out, ipar, &type, indDIM); } else { F77_CALL(dsparsekit) (derivs, &neq, &nnz, &nsp, &tin, svar, dsvar, beta, x, alpha, ewt, ian, jan, igp, jgp, &ngp, jlu, ju, iwork, iperm, &maxit, &Chtol, Atol, Rtol, &Itol, &posit, pos, &ipos, &isSteady, precis, &niter, dims, out, ipar, &type, &droptol, &permtol, &ilumethod, &lfill, &lenplumx, plu, rwork, indDIM); } for (j = 0; j < ny; j++) REAL(yout)[j] = svar[j]; if (isOut == 1) { derivs (&neq, &tin, svar, dsvar, out, ipar) ; for (j = 0; j < nout; j++) REAL(yout)[j + ny] = out[j]; } PROTECT(RWORK = allocVector(REALSXP, niter));incr_N_Protect(); for (k = 0;k<niter;k++) REAL(RWORK)[k] = precis[k]; if (mflag == 1) Rprintf("mean residual derivative %g\n",precis[niter-1]); setAttrib(yout, install("precis"), RWORK); PROTECT(IWORK = allocVector(INTSXP, 4));incr_N_Protect(); INTEGER(IWORK)[0] = isSteady; for (k = 0; k<3; k++) INTEGER(IWORK)[k+1] = dims[k]; setAttrib(yout, install("steady"), IWORK); unprotect_all(); return(yout); }
/* browser(text = "", condition = NULL, expr = TRUE, skipCalls = 0L) * ------- but also called from ./eval.c */ SEXP attribute_hidden do_browser(SEXP call, SEXP op, SEXP args, SEXP rho) { RCNTXT *saveToplevelContext; RCNTXT *saveGlobalContext; RCNTXT thiscontext, returncontext, *cptr; int savestack, browselevel; SEXP ap, topExp, argList; /* argument matching */ PROTECT(ap = list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue)); SET_TAG(ap, install("text")); SET_TAG(CDR(ap), install("condition")); SET_TAG(CDDR(ap), install("expr")); SET_TAG(CDDDR(ap), install("skipCalls")); argList = matchArgs(ap, args, call); UNPROTECT(1); PROTECT(argList); /* substitute defaults */ if(CAR(argList) == R_MissingArg) SETCAR(argList, mkString("")); if(CADR(argList) == R_MissingArg) SETCAR(CDR(argList), R_NilValue); if(CADDR(argList) == R_MissingArg) SETCAR(CDDR(argList), ScalarLogical(1)); if(CADDDR(argList) == R_MissingArg) SETCAR(CDDDR(argList), ScalarInteger(0)); /* return if 'expr' is not TRUE */ if( !asLogical(CADDR(argList)) ) { UNPROTECT(1); return R_NilValue; } /* Save the evaluator state information */ /* so that it can be restored on exit. */ browselevel = countContexts(CTXT_BROWSER, 1); savestack = R_PPStackTop; PROTECT(topExp = R_CurrentExpr); saveToplevelContext = R_ToplevelContext; saveGlobalContext = R_GlobalContext; if (!RDEBUG(rho)) { int skipCalls = asInteger(CADDDR(argList)); cptr = R_GlobalContext; while ( ( !(cptr->callflag & CTXT_FUNCTION) || skipCalls--) && cptr->callflag ) cptr = cptr->nextcontext; Rprintf("Called from: "); int tmp = asInteger(GetOption(install("deparse.max.lines"), R_BaseEnv)); if(tmp != NA_INTEGER && tmp > 0) R_BrowseLines = tmp; if( cptr != R_ToplevelContext ) { PrintValueRec(cptr->call, rho); SET_RDEBUG(cptr->cloenv, 1); } else Rprintf("top level \n"); R_BrowseLines = 0; } R_ReturnedValue = R_NilValue; /* Here we establish two contexts. The first */ /* of these provides a target for return */ /* statements which a user might type at the */ /* browser prompt. The (optional) second one */ /* acts as a target for error returns. */ begincontext(&returncontext, CTXT_BROWSER, call, rho, R_BaseEnv, argList, R_NilValue); if (!SETJMP(returncontext.cjmpbuf)) { begincontext(&thiscontext, CTXT_RESTART, R_NilValue, rho, R_BaseEnv, R_NilValue, R_NilValue); if (SETJMP(thiscontext.cjmpbuf)) { SET_RESTART_BIT_ON(thiscontext.callflag); R_ReturnedValue = R_NilValue; R_Visible = FALSE; } R_GlobalContext = &thiscontext; R_InsertRestartHandlers(&thiscontext, TRUE); R_ReplConsole(rho, savestack, browselevel+1); endcontext(&thiscontext); } endcontext(&returncontext); /* Reset the interpreter state. */ R_CurrentExpr = topExp; UNPROTECT(1); R_PPStackTop = savestack; UNPROTECT(1); R_CurrentExpr = topExp; R_ToplevelContext = saveToplevelContext; R_GlobalContext = saveGlobalContext; return R_ReturnedValue; }
/** * utility function to print out acceptance rates * * @param n number of iterations * @param p the length of acc * @param acc a vector that stores acceptance times or percentages * @param pct indicating whether acc is the acceptance percentage or the unscaled acceptance times * */ static R_INLINE void print_acc(int n, int p, double *acc, int pct){ double C = (pct) ? 100 : (100.0/n); Rprintf(_("Acceptance rate: min(%4.2f%%), mean(%4.2f%%), max(%4.2f%%)\n"), dmin(acc, p) * C, mean(acc, p) * C, dmax(acc, p) * C); }
/** * Main function for cwb-align-encode. * * @param argc Number of command-line arguments. * @param argv Command-line arguments. */ int main(int argc, char *argv[]) { int argindex; /* index of first argument in argv[] */ char *align_name = NULL; /* name of the .align file */ FILE *af = NULL; /* alignment file handle */ int af_is_pipe; /* need to know whether to call fclose() or pclose() */ char alx_name[CL_MAX_LINE_LENGTH]; /* full pathname of .alx file */ char alg_name[CL_MAX_LINE_LENGTH]; /* full pathname of optional .alg file */ FILE *alx=NULL, *alg=NULL; /* file handles for .alx and optional .alg file */ char line[CL_MAX_LINE_LENGTH]; /* one line of input from <infile> */ char corpus1_name[CL_MAX_FILENAME_LENGTH]; char corpus2_name[CL_MAX_FILENAME_LENGTH]; char s1_name[CL_MAX_FILENAME_LENGTH]; char s2_name[CL_MAX_FILENAME_LENGTH]; Corpus *corpus1, *corpus2; /* corpus handles */ Attribute *w1, *w2; /* attribute handles for 'word' attributes; used to determine corpus size */ int size1, size2; /* size of source & target corpus */ Corpus *source_corpus; /* encode alignment in this corpus (depends on -R flag, important for -D option) */ char *source_corpus_name; /* just for error messages */ char *attribute_name; /* name of alignment attribute (depends on -R flag, must be lowercase) */ int f1,l1,f2,l2; /* alignment regions */ int current1, current2; int mark, n_0_1, n_1_0; int l; progname = argv[0]; /* parse command line and read arguments */ argindex = alignencode_parse_args(argc, argv, 1); align_name = argv[argindex]; /* open alignment file and parse header; .gz files are automatically decompressed */ af_is_pipe = 0; l = strlen(align_name); if ((l > 3) && (strncasecmp(align_name + l - 3, ".gz", 3) == 0)) { char *pipe_cmd = (char *) cl_malloc(l+10); sprintf(pipe_cmd, "gzip -cd %s", align_name); /* write .gz file through gzip pipe */ af = popen(pipe_cmd, "r"); if (af == NULL) { perror(pipe_cmd); Rprintf( "%s: can't read compressed file %s\n", progname, align_name); rcqp_receive_error(1); } af_is_pipe = 1; cl_free(pipe_cmd); } else { af = fopen(align_name, "r"); if (af == NULL) { perror(align_name); Rprintf( "%s: can't read file %s\n", progname, align_name); rcqp_receive_error(1); } } /* read header = first line */ fgets(line, CL_MAX_LINE_LENGTH, af); if (4 != sscanf(line, "%s %s %s %s", corpus1_name, s1_name, corpus2_name, s2_name)) { Rprintf( "%s: %s not in .align format\n", progname, align_name); Rprintf( "wrong header: %s", line); rcqp_receive_error(1); } if (verbose) { if (reverse) Rprintf("Encoding alignment for [%s, %s] from file %s\n", corpus2_name, corpus1_name, align_name); else Rprintf("Encoding alignment for [%s, %s] from file %s\n", corpus1_name, corpus2_name, align_name); } /* open corpora and determine their sizes (for validity checks and compatibility mode) */ if (NULL == (corpus1 = cl_new_corpus(registry_dir, corpus1_name))) { Rprintf( "%s: can't open corpus %s\n", progname, corpus1_name); rcqp_receive_error(1); } if (NULL == (corpus2 = cl_new_corpus(registry_dir, corpus2_name))) { Rprintf( "%s: can't open corpus %s\n", progname, corpus2_name); rcqp_receive_error(1); } if (NULL == (w1 = cl_new_attribute(corpus1, "word", ATT_POS))) { Rprintf( "%s: can't open p-attribute %s.word\n", progname, corpus1_name); rcqp_receive_error(1); } if (NULL == (w2 = cl_new_attribute(corpus2, "word", ATT_POS))) { Rprintf( "%s: can't open p-attribute %s.word\n", progname, corpus2_name); rcqp_receive_error(1); } size1 = cl_max_cpos(w1); if (size1 <= 0) { Rprintf( "%s: data access error (%s.word)\n", progname, corpus1_name); rcqp_receive_error(1); } size2 = cl_max_cpos(w2); if (size2 <= 0) { Rprintf( "%s: data access error (%s.word)\n", progname, corpus2_name); rcqp_receive_error(1); } /* now work out the actual source corpus and the alignment attribute name (depending on -R flag) */ source_corpus = (reverse) ? corpus2 : corpus1; source_corpus_name = (reverse) ? corpus2_name : corpus1_name; attribute_name = cl_strdup((reverse) ? corpus1_name : corpus2_name); cl_id_tolower(attribute_name); /* fold attribute name to lowercase */ /* with -D option, determine data file name(s) from actual source corpus; otherwise use directory specified with -d and the usual naming conventions */ if (data_dir_from_corpus) { Attribute *alignment = cl_new_attribute(source_corpus, attribute_name, ATT_ALIGN); char *comp_pathname; if (alignment == NULL) { Rprintf( "%s: alignment attribute %s.%s not declared in registry file\n", progname, source_corpus_name, attribute_name); rcqp_receive_error(1); } comp_pathname = component_full_name(alignment, CompXAlignData, NULL); if (comp_pathname == NULL) { Rprintf( "%s: can't determine pathname for .alx file (internal error)\n", progname); rcqp_receive_error(1); } strcpy(alx_name, comp_pathname); /* need to strcpy because component_full_name() returns pointer to internal buffer */ if (compatibility) { comp_pathname = component_full_name(alignment, CompAlignData, NULL); if (comp_pathname == NULL) { Rprintf( "%s: can't determine pathname for .alg file (internal error)\n", progname); rcqp_receive_error(1); } strcpy(alg_name, comp_pathname); } } else { sprintf(alx_name, "%s" SUBDIR_SEP_STRING "%s.alx", data_dir, attribute_name); if (compatibility) sprintf(alg_name, "%s" SUBDIR_SEP_STRING "%s.alg", data_dir, attribute_name); } /* now open output file(s) */ alx = fopen(alx_name, "wb"); if (alx == NULL) { perror(alx_name); Rprintf( "%s: can't write file %s\n", progname, alx_name); rcqp_receive_error(1); } if (verbose) Rprintf("Writing file %s ...\n", alx_name); if (compatibility) { alg = fopen(alg_name, "wb"); if (alg == NULL) { perror(alg_name); Rprintf( "%s: can't write file %s\n", progname, alg_name); rcqp_receive_error(1); } if (verbose) Rprintf("Writing file %s ...\n", alg_name); } /* main encoding loop */ f1 = f2 = l1 = l2 = 0; mark = -1; /* check that regions occur in ascending order */ current1 = current2 = -1; /* for compatibility mode */ n_0_1 = n_1_0 = 0; /* number of 0:1 and 1:0 alignments, which are skipped */ while (! feof(af)) { if (NULL == fgets(line, CL_MAX_LINE_LENGTH, af)) break; /* end of file (or read error, which we choose to ignore) */ if (4 != sscanf(line, "%d %d %d %d", &f1, &l1, &f2, &l2)) { Rprintf( "%s: input format error: %s", progname, line); rcqp_receive_error(1); } /* skip 0:1 and 1:0 alignments */ if (l1 < f1) { n_0_1++; continue; } if (l2 < f2) { n_1_0++; continue; } /* check that source regions are non-overlapping and in ascending order */ if (((reverse) ? f2 : f1) <= mark) { Rprintf( "%s: source regions of alignment must be in ascending order\n", progname); Rprintf( "Last region was [*, %d]; current is [%d, %d].\n", mark, f1, l1); Rprintf( "Aborted.\n"); rcqp_receive_error(1); } mark = (reverse) ? l2 : l1; /* write alignment region to .alx file */ if (reverse) { NwriteInt(f2, alx); NwriteInt(l2, alx); NwriteInt(f1, alx); NwriteInt(l1, alx); } else { NwriteInt(f1, alx); NwriteInt(l1, alx); NwriteInt(f2, alx); NwriteInt(l2, alx); } if (compatibility) { /* source and target regions of .alg file must be contiguous; store start points only; */ /* hence we must collapse crossing alignments into one larger region (I know that's bullshit) */ if ((f1 > current1) && (f2 > current2)) { if (reverse) { NwriteInt(f2, alg); NwriteInt(f1, alg); } else { NwriteInt(f1, alg); NwriteInt(f2, alg); } current1 = f1; current2 = f2; } } } if (compatibility) { if (reverse) { NwriteInt(size2, alg); NwriteInt(size1, alg); /* end of corpus alignment point*/ } else { NwriteInt(size1, alg); NwriteInt(size2, alg); /* end of corpus alignment point*/ } } if (verbose) { Rprintf("I skipped %d 0:1 alignments and %d 1:0 alignments.\n", n_0_1, n_1_0); } /* that's it; close file handles */ fclose(alx); if (compatibility) fclose(alg); if (af_is_pipe) pclose(af); else fclose(af); return 0; }
// to print in the R interface for GP models, for temporal beta void GPsptp_para_printRnu (int i, int iteration, int report, int p, int u, double accept, double *phi, double *nu, double *sig2e, double *sig2eta, double *sig2beta, double *sig2delta, double *sig20, double *rho, double *beta) { int j, k; double phi1, nu1, sig2e1, sig2eta1, sig2beta1, sig2delta1, sig201, ii; phi1 = *phi; nu1 =*nu; sig2e1 = *sig2e; sig2eta1 = *sig2eta; sig2beta1 = *sig2beta; sig2delta1 = *sig2delta; sig201 = *sig20; double num = (iteration/report); int intpart = (int)num; for(j=0; j<report; j++){ if(i==(intpart*(j+1)-1)){ ii = (double) i; Rprintf("---------------------------------------------------------------\n"); Rprintf(" Sampled: %i of %i, %3.2f%%.\n Batch Acceptance Rate (phi): %3.2f%%\n", i+1, iteration, 100.0*(i+1)/iteration, 100.0*(accept/ii)); Rprintf(" Checking Parameters: \n"); Rprintf(" phi: %4.4f, nu: %4.4f, sig2eps: %4.4f, sig2eta: %4.4f,\n sig2beta: %4.4f, sig2delta: %4.4f, sig2op: %4.4f,\n", phi1, nu1, sig2e1, sig2eta1, sig2beta1, sig2delta1, sig201); for(k=0; k<u; k++){ Rprintf(" rho[%d]: %4.4f", k+1, rho[k]); } Rprintf("\n"); for(k=0; k<p; k++){ Rprintf(" beta[%d]: %4.4f", k+1, beta[k]); } Rprintf("\n---------------------------------------------------------------\n"); Rprintf(" ## Model used spatially and temporally varying dynamic parameters \n"); Rprintf(" ## Spatial and dynamic beta parameters are omitted in the display "); Rprintf("\n---------------------------------------------------------------\n"); } } return; }
/** * Prints a message describing how to use the program to STDERR and then exits. */ void alignencode_usage(void) { Rprintf( "\n"); Rprintf( "Usage: %s [options] <alignment_file>\n\n", progname); Rprintf( "\n"); Rprintf( "Adds an alignment attribute to an existing CWB corpus\n"); Rprintf( "\n"); Rprintf( "Options:\n"); Rprintf( " -d <dir> write data file(s) to directory <dir>\n"); Rprintf( " -D write files to corpus data directory\n"); Rprintf( " -C compatibility mode (creates .alg file)\n"); /* Rprintf( " -R reverse alignment (target -> source)\n"); */ /* -R option disabled ... need to re-order alignment file for reverse alignment */ Rprintf( " -r <reg> use registry directory <reg>\n"); Rprintf( " -v verbose mode\n"); Rprintf( " -h this help page\n\n"); Rprintf( "Part of the IMS Open Corpus Workbench v" VERSION "\n\n"); rcqp_receive_error(1); }
/* print prefix */ static void pp(int pre) { /* this is sort of silly, I know, but it saves at least some output calls (and we can replace \t by spaces if desired) ... */ while (pre >= 8) { Rprintf("\t"); pre -= 8; } while (pre-- > 0) Rprintf(" "); }
/** * Parses the program's commandline arguments. * * Usage: * * optindex = alignencode_parse_args(argc, argv, required_arguments); * * @param ac The program's argc * @param av The program's argv * @param min_args Minimum number of arguments to be parsed. * @return The value of optind after parsing, * ie the index of the first argument in argv[] */ int alignencode_parse_args(int ac, char *av[], int min_args) { extern int optind; /* getopt() interface */ extern char *optarg; /* getopt() interface */ int c; while ((c = getopt(ac, av, "hd:DCRr:v")) != EOF) switch (c) { /* -d: data directory */ case 'd': if (data_dir == NULL) data_dir = optarg; else { Rprintf( "%s: -d option used twice\n", progname); rcqp_receive_error(2); } break; /* -D: use data directory of source corpus */ case 'D': data_dir_from_corpus = 1; break; /* -C: compatibility mode */ case 'C': compatibility = 1; break; /* -R: reverse alignment */ case 'R': reverse = 1; break; /* -r: registry directory */ case 'r': if (registry_dir == NULL) registry_dir = optarg; else { Rprintf( "%s: -r option used twice\n", progname); rcqp_receive_error(2); } break; /* -v: verbose */ case 'v': verbose = 1; break; /* -h : help page = usage */ case 'h': /* unknown option: print usage */ default: alignencode_usage(); break; } if (ac - optind != min_args) alignencode_usage(); /* no optional arguments in this case */ if ((data_dir == NULL) && (! data_dir_from_corpus)) { Rprintf( "%s: either -d or -D must be specified\n", progname); Rprintf( "Type \"%s -h\" for more information.\n", progname); rcqp_receive_error(1); } if ((data_dir != NULL) && data_dir_from_corpus) { Rprintf( "%s: -d and -D flags cannot be used at the same time\n", progname); Rprintf( "Type \"%s -h\" for more information.\n", progname); rcqp_receive_error(1); } return(optind); /* return index of first argument in argv[] */ }
/* * start the process of loading a sequence list file */ bool msequenceServer::start(void) { m_bStarted = false; /* * return false if there are no more sequence list files */ if(m_dstrFasta.empty()) { return false; } m_strPath = m_dstrFasta.front(); m_dstrFasta.pop_front(); m_vstrPaths.push_back(m_strPath); /* * open the file */ m_pInput = fopen(m_strPath.c_str(),"rb"); if(m_pInput == NULL) { m_bError = true; m_strStatus = "\n*********\nWarning:\n Sequence list path '"; m_strStatus += m_strPath; m_strStatus += "'\n could not be opened and was skipped.\n*********\n\n"; // cout << m_strStatus.c_str(); Rprintf("%s", m_strStatus.c_str()); return m_bStarted; } size_t tS = 0; char *pS = NULL; tS = fread(m_pLine,256,1,m_pInput); tS++; /* fool the compiler */ string strDesc = "no description"; if(strstr(m_pLine,"xbang-pro-fasta-format") != NULL) { m_lFileType = XBANG; char *pV = m_pLine+64; if(strlen(pV) > 0) { strDesc = pV; } } else if(m_pLine[0] == '>') { fclose(m_pInput); m_lFileType = FASTA; m_pInput = fopen(m_strPath.c_str(),"r"); } else { m_lFileType = UNKNOWN; m_bError = true; m_strStatus = "\n*********\nWarning:\n Sequence list path '"; m_strStatus += m_strPath; m_strStatus += "'\n was not in a recognized file format and was skipped.\n*********\n\n"; // cout << m_strStatus.c_str(); Rprintf("%s", m_strStatus.c_str()); return m_bStarted; } m_vstrDesc.push_back(strDesc); m_bStarted = true; m_strStatus += "Path '"; m_strStatus += m_strPath; m_strStatus += "' was opened.\n"; /* * read down to the first valid FASTA description line */ if(m_lFileType == XBANG) return m_bStarted; pS = fgets(m_pLine,m_lSize,m_pInput); while(m_pLine[0] != '>' && !feof(m_pInput)) { pS = fgets(m_pLine,m_lSize,m_pInput); } pS++; /* fool the compiler */ if(m_pLine[0] == '>') { char *pEol = NULL; if(strchr(m_pLine,0x01)) { pEol = strchr(m_pLine,0x01); *pEol = '\0'; } else { pEol = m_pLine + strlen(m_pLine) - 1; while(pEol > m_pLine && isspace(*pEol)) { *pEol = '\0'; pEol--; } } pEol = strchr(m_pLine,'\r'); if(pEol) { *pEol = '\0'; } pEol = strchr(m_pLine,'\n'); if(pEol) { *pEol = '\0'; } m_strFirst = m_pLine+1; } /* * create the msequencecollection object, if necessary */ return m_bStarted; }
void strat_sizes(int *nn, double *enter, double *exit, int *event, int *antrs, double *risktimes, int *n_events,int *size){ /** nn = stratum size, enter[nn], exit[nn], event[nn] as usual antrs = No. of risksets in this stratum. risktimes[nn] (e.g. risksets[antrs]) n.events[nn], size[nn] (eg [antrs] )! **/ /* Data sorted ascending wrt exit, descending wrt event (for tied exit) */ int i, start, nextstart; double th; for (i = 0; i < *nn; i++){ n_events[i] = 0; size[i] = 0; } *antrs = 0; start = 0; while (start < *nn){ /* Reordered conditions in 2.2-3: */ /* for (nextstart = start; (nextstart < *nn) & (event[nextstart] == 0); nextstart++); */ nextstart = start; while (nextstart < *nn){ if (event[nextstart] == 1) break; nextstart++; } if (nextstart >= *nn) return; /* Done in this stratum! */ if (*antrs >= *nn) Rprintf("Error antrs in [sizes]\n"); th = exit[nextstart]; risktimes[*antrs] = th; /* Reordered conditions in 2.2-3: */ /* for (start = nextstart; (start < *nn) & (exit[start] == th) & (event[start] == 1); start++){ */ start = nextstart; while (start < *nn){ if ((exit[start] == th) & (event[start] == 1)){ n_events[*antrs]++; size[*antrs]++; }else{ break; } start++; } for (i = start; i < *nn; i++){ if (enter[i] < th) size[*antrs]++; } (*antrs)++; } }
/* 30 FORMAT(/10H IT NF,6X,1HF,7X,5HRELDF,3X,6HPRELDF,3X,5HRELDX, 1 2X,13HMODEL STPPAR) */ void F77_SUB(h30)(void) { Rprintf("\n IT NF F RELDF PRELDF RELDX MODEL STPPAR\n"); }
SEXP read_png(SEXP sFn, SEXP sNative, SEXP sInfo) { SEXP res = R_NilValue, info_list = R_NilValue, info_tail = R_NilValue; const char *fn; char header[8]; int native = asInteger(sNative), info = (asInteger(sInfo) == 1); FILE *f; read_job_t rj; png_structp png_ptr; png_infop info_ptr; if (TYPEOF(sFn) == RAWSXP) { rj.data = (char*) RAW(sFn); rj.len = LENGTH(sFn); rj.ptr = 0; rj.f = f = 0; } else { if (TYPEOF(sFn) != STRSXP || LENGTH(sFn) < 1) Rf_error("invalid filename"); fn = CHAR(STRING_ELT(sFn, 0)); f = fopen(fn, "rb"); if (!f) Rf_error("unable to open %s", fn); if (fread(header, 1, 8, f) < 1 || png_sig_cmp((png_bytep) header, 0, 8)) { fclose(f); Rf_error("file is not in PNG format"); } rj.f = f; } /* use our own error hanlding code and pass the fp so it can be closed on error */ png_ptr = png_create_read_struct(PNG_LIBPNG_VER_STRING, (png_voidp)&rj, user_error_fn, user_warning_fn); if (!png_ptr) { if (f) fclose(f); Rf_error("unable to initialize libpng"); } info_ptr = png_create_info_struct(png_ptr); if (!info_ptr) { if (f) fclose(f); png_destroy_read_struct(&png_ptr, (png_infopp)NULL, (png_infopp)NULL); Rf_error("unable to initialize libpng"); } if (f) { png_init_io(png_ptr, f); png_set_sig_bytes(png_ptr, 8); } else png_set_read_fn(png_ptr, (png_voidp) &rj, user_read_data); #define add_info(K, V) { info_tail = SETCDR(info_tail, CONS(V, R_NilValue)); SET_TAG(info_tail, install(K)); } /* png_read_png(png_ptr, info_ptr, PNG_TRANSFORM_STRIP_16 | PNG_TRANSFORM_EXPAND, NULL); */ png_read_info(png_ptr, info_ptr); { png_uint_32 width, height; png_bytepp row_pointers; char *img_memory; SEXP dim; int bit_depth, color_type, interlace_type, compression_type, filter_method, rowbytes; int need_swap = 0; png_get_IHDR(png_ptr, info_ptr, &width, &height, &bit_depth, &color_type, &interlace_type, &compression_type, &filter_method); rowbytes = png_get_rowbytes(png_ptr, info_ptr); #if VERBOSE_INFO Rprintf("png: %d x %d [%d], %d bytes, 0x%x, %d, %d\n", (int) width, (int) height, bit_depth, rowbytes, color_type, interlace_type, compression_type, filter_method); #endif if (info) { SEXP dv; double d; png_uint_32 rx, ry; int ut, num_text = 0; png_textp text_ptr; info_tail = info_list = PROTECT(CONS((dv = allocVector(INTSXP, 2)), R_NilValue)); INTEGER(dv)[0] = (int) width; INTEGER(dv)[1] = (int) height; SET_TAG(info_list, install("dim")); add_info("bit.depth", ScalarInteger(bit_depth)); switch(color_type) { case PNG_COLOR_TYPE_GRAY: add_info("color.type", mkString("gray")); break; case PNG_COLOR_TYPE_GRAY_ALPHA: add_info("color.type", mkString("gray + alpha")); break; case PNG_COLOR_TYPE_PALETTE: add_info("color.type", mkString("palette")); break; case PNG_COLOR_TYPE_RGB: add_info("color.type", mkString("RGB")); break; case PNG_COLOR_TYPE_RGB_ALPHA: add_info("color.type", mkString("RGBA")); break; default: add_info("color.type", ScalarInteger(color_type)); } if (png_get_gAMA(png_ptr, info_ptr, &d)) add_info("gamma", ScalarReal(d)); #ifdef PNG_pHYs_SUPPORTED if (png_get_pHYs(png_ptr, info_ptr, &rx, &ry, &ut)) { if (ut == PNG_RESOLUTION_METER) { dv = allocVector(REALSXP, 2); REAL(dv)[0] = ((double)rx) / 39.37008; REAL(dv)[1] = ((double)ry) / 39.37008; add_info("dpi", dv); } else if (ut == PNG_RESOLUTION_UNKNOWN) add_info("asp", ScalarReal(rx / ry)); } if (png_get_text(png_ptr, info_ptr, &text_ptr, &num_text)) { SEXP txt_key, txt_val = PROTECT(allocVector(STRSXP, num_text)); if (num_text) { int i; setAttrib(txt_val, R_NamesSymbol, txt_key = allocVector(STRSXP, num_text)); for (i = 0; i < num_text; i++) { SET_STRING_ELT(txt_val, i, text_ptr[i].text ? mkChar(text_ptr[i].text) : NA_STRING); SET_STRING_ELT(txt_key, i, text_ptr[i].key ? mkChar(text_ptr[i].key) : NA_STRING); } } add_info("text", txt_val); UNPROTECT(1); } #endif } /* on little-endian machines it's all well, but on big-endian ones we'll have to swap */ #if ! defined (__BIG_ENDIAN__) && ! defined (__LITTLE_ENDIAN__) /* old compiler so have to use run-time check */ { char bo[4] = { 1, 0, 0, 0 }; int bi; memcpy(&bi, bo, 4); if (bi != 1) need_swap = 1; } #endif #ifdef __BIG_ENDIAN__ need_swap = 1; #endif /*==== set any transforms that we desire: ====*/ /* palette->RGB - no discussion there */ if (color_type == PNG_COLOR_TYPE_PALETTE) png_set_palette_to_rgb(png_ptr); /* expand gray scale to 8 bits */ if (color_type == PNG_COLOR_TYPE_GRAY && bit_depth < 8) png_set_expand_gray_1_2_4_to_8(png_ptr); /* this should not be necessary but it's in the docs to guarantee 8-bit */ if (bit_depth < 8) png_set_packing(png_ptr); /* convert tRNS chunk into alpha */ if (png_get_valid(png_ptr, info_ptr, PNG_INFO_tRNS)) png_set_tRNS_to_alpha(png_ptr); /* native format doesn't allow for 16-bit so it needs to be truncated */ if (bit_depth == 16 && native) { Rf_warning("Image uses 16-bit channels but R native format only supports 8-bit, truncating LSB."); png_set_strip_16(png_ptr); } /* for native output we need to a) convert gray to RGB, b) add alpha */ if (native) { if (color_type == PNG_COLOR_TYPE_GRAY || color_type == PNG_COLOR_TYPE_GRAY_ALPHA) png_set_gray_to_rgb(png_ptr); if (!(color_type & PNG_COLOR_MASK_ALPHA)) /* if there is no alpha, add it */ png_set_add_alpha(png_ptr, 0xFF, PNG_FILLER_AFTER); } #if 0 /* we use native (network) endianness since we read each byte anyway */ /* on little-endian machines we need to swap 16-bit values - this is the inverse of need_swap as used for R! */ if (!need_swap && bit_depth == 16) png_set_swap(png_ptr); #endif /* PNG wants up to call png_set_interlace_handling so it can get ready to de-interlace images */ png_set_interlace_handling(png_ptr); /* all transformations are in place, so it's time to update the info structure so we can allocate stuff */ png_read_update_info(png_ptr, info_ptr); /* re-read some important bits from the updated structure */ rowbytes = png_get_rowbytes(png_ptr, info_ptr); bit_depth = png_get_bit_depth(png_ptr, info_ptr); color_type = png_get_color_type(png_ptr, info_ptr); #if VERBOSE_INFO Rprintf(" -filter-> %d-bits, %d bytes, 0x%x\n", bit_depth, rowbytes, color_type); #endif /* allocate data fro row pointers and the image using R's allocation */ row_pointers = (png_bytepp) R_alloc(height, sizeof(png_bytep)); img_memory = R_alloc(height, rowbytes); { /* populate the row pointers */ char *i_ptr = img_memory; int i; for (i = 0; i < height; i++, i_ptr += rowbytes) row_pointers[i] = (png_bytep) i_ptr; } /* do the reading work */ png_read_image(png_ptr, row_pointers); if (f) { rj.f = 0; fclose(f); } /* native output - vector of integers */ if (native) { int pln = rowbytes / width; if (pln < 1 || pln > 4) { png_destroy_read_struct(&png_ptr, &info_ptr, (png_infopp)NULL); Rf_error("native output for %d planes is not possible.", pln); } res = PROTECT(allocVector(INTSXP, width * height)); if (pln == 4) { /* 4 planes - efficient - just copy it all */ int y, *idata = INTEGER(res); for (y = 0; y < height; idata += width, y++) memcpy(idata, row_pointers[y], width * sizeof(int)); if (need_swap) { int *ide = idata; idata = INTEGER(res); for (; idata < ide; idata++) RX_swap32(*idata); } } else if (pln == 3) { /* RGB */ int x, y, *idata = INTEGER(res); for (y = 0; y < height; y++) for (x = 0; x < rowbytes; x += 3) *(idata++) = R_RGB((unsigned int) row_pointers[y][x], (unsigned int) row_pointers[y][x + 1], (unsigned int) row_pointers[y][x + 2]); } else if (pln == 2) { /* GA */ int x, y, *idata = INTEGER(res); for (y = 0; y < height; y++) for (x = 0; x < rowbytes; x += 2) *(idata++) = R_RGBA((unsigned int) row_pointers[y][x], (unsigned int) row_pointers[y][x], (unsigned int) row_pointers[y][x], (unsigned int) row_pointers[y][x + 1]); } else { /* gray */ int x, y, *idata = INTEGER(res); for (y = 0; y < height; y++) for (x = 0; x < rowbytes; x++) *(idata++) = R_RGB((unsigned int) row_pointers[y][x], (unsigned int) row_pointers[y][x], (unsigned int) row_pointers[y][x]); } dim = allocVector(INTSXP, 2); INTEGER(dim)[0] = height; INTEGER(dim)[1] = width; setAttrib(res, R_DimSymbol, dim); setAttrib(res, R_ClassSymbol, mkString("nativeRaster")); setAttrib(res, install("channels"), ScalarInteger(pln)); UNPROTECT(1); } else { int x, y, p, pln = rowbytes / width, pls = width * height; double * data; if (bit_depth == 16) { res = PROTECT(allocVector(REALSXP, (rowbytes * height) / 2)); pln /= 2; } else res = PROTECT(allocVector(REALSXP, rowbytes * height)); data = REAL(res); if (bit_depth == 16) for(y = 0; y < height; y++) for (x = 0; x < width; x++) for (p = 0; p < pln; p++) data[y + x * height + p * pls] = ((double)( (((unsigned int)(((unsigned char *)row_pointers[y])[2 * (x * pln + p)])) << 8) | ((unsigned int)(((unsigned char *)row_pointers[y])[2 * (x * pln + p) + 1])) )) / 65535.0; else for(y = 0; y < height; y++) for (x = 0; x < width; x++) for (p = 0; p < pln; p++) data[y + x * height + p * pls] = ((double)row_pointers[y][x * pln + p]) / 255.0; dim = allocVector(INTSXP, (pln > 1) ? 3 : 2); INTEGER(dim)[0] = height; INTEGER(dim)[1] = width; if (pln > 1) INTEGER(dim)[2] = pln; setAttrib(res, R_DimSymbol, dim); UNPROTECT(1); } } if (info) { PROTECT(res); setAttrib(res, install("info"), info_list); UNPROTECT(2); } png_destroy_read_struct(&png_ptr, &info_ptr, (png_infopp)NULL); return res; }