void marker_loglik(int n_ind, int n_gen, int *geno, double error_prob, double initf(int, int *), double emitf(int, int, double, int *), double *loglik) { int i, v; double temp; int cross_scheme[2]; /* cross scheme hidden in loglik argument; used by hmm_bcsft */ cross_scheme[0] = (int) ftrunc(*loglik / 1000.0); cross_scheme[1] = ((int) *loglik) - 1000 * cross_scheme[0]; *loglik = 0.0; for(i=0; i<n_ind; i++) { /* i = individual */ R_CheckUserInterrupt(); /* check for ^C */ temp = initf(1, cross_scheme) + emitf(geno[i], 1, error_prob, cross_scheme); for(v=1; v<n_gen; v++) temp = addlog(temp, initf(v+1, cross_scheme) + emitf(geno[i], v+1, error_prob, cross_scheme)); (*loglik) += temp; } }
int scot(FILE *inf, FILE *outf, char *fil) { char s[128]; Inst *insttop, *ip; initf(inf, outf, fil); if (findword(s) || strcmp(s, "orchestra")) scotferror(Str("Score must start with orchestra section")); readorch(&insttop); for (;;) { if (findword(s)) break; if (!strcmp(s, "functions")) readfunctions(); else if (!strcmp(s, "score")) readscore(insttop); else scotferror(Str("Expected score or functions section")); } fputs("e\n", outfile); while (insttop) { ip = insttop; insttop = insttop->next; free(ip->name); free((char *) ip); } if (errcount) reporterrcount(); return errcount; }
void marker_loglik(int n_ind, int n_gen, int *geno, double error_prob, double initf(int), double emitf(int, int, double), double *loglik) { int i, v; double temp; *loglik = 0.0; for(i=0; i<n_ind; i++) { /* i = individual */ R_CheckUserInterrupt(); /* check for ^C */ temp = initf(1) + emitf(geno[i], 1, error_prob); for(v=1; v<n_gen; v++) temp = addlog(temp, initf(v+1) + emitf(geno[i], v+1, error_prob)); (*loglik) += temp; } }
int main (){ float tab[N]; float tab2[N]; initf(tab, N); // read(tab, N); copyf(tab, tab2, N); priintf(tab2, N); npermutf(tab2, N, 2); priintf(tab2, N); char tab3[N]; char tab4[N]; char tab5[N]; initc(tab3, N); initc(tab4, N); initc(tab5, N); npermutc(tab4, N, 1); minToMaj(tab5, N); printc(tab3, N); printc(tab4, N); printc(tab5, N); mirror(tab4, N); printc(tab3, N); printc(tab4, N); printc(tab5, N); printf("%d\n", searchs(tab3, tab4, N, N)); printf("%d\n", searchs(tab3, tab5, N, N)); frac ax = {30, 50}; frac bx = {30, 50}; printf("frac %d %d\n", ax.nume, ax.deno); simplify(&ax); printf("simply frac %d %d\n", ax.nume, ax.deno); return 0; }
static void comsubst(void) { /* command substn */ FILEBLK cb; register char d; register STKPTR savptr = fixstak(); usestak(); while ((d = readc()) != SQUOTE && d) pushstak(d); { register char *argc; trim(argc = fixstak()); push(&cb); estabf(argc); } { register TREPTR t = makefork(FPOU, cmd(EOFSYM, MTFLG | NLFLG)); int pv[2]; /* this is done like this so that the pipe * is open only when needed */ chkpipe(pv); initf(pv[INPIPE]); execute(t, 0, 0, pv); close(pv[OTPIPE]); } tdystak(savptr); staktop = movstr(savptr, stakbot); while (d = readc()) pushstak(d | quote); await(0); while (stakbot != staktop) { if ((*--staktop & STRIP) != NL) { ++staktop; break; } } pop(); }
void * radiusd_load_ext(const char *name, const char *ident, void **symbol) { lt_dlhandle handle; GRAD_DEBUG2(1,"Loading module '%s', symbol '%s'", name, ident); if (lt_dlinit()) { GRAD_DEBUG(1,"lt_ldinit failed"); return NULL; } handle = lt_dlopenext(name); if (handle) { *symbol = lt_dlsym(handle, ident); if (*symbol) { grad_dl_init_t initf = (grad_dl_init_t) lt_dlsym(handle, "init"); if (initf) { if (initf()) { grad_log(GRAD_LOG_ERR, _("Cannot load module %s: init function failed"), name); lt_dlclose(handle); handle = NULL; } } } else { grad_log(GRAD_LOG_ERR, _("Cannot load module %s: symbol %s not found"), name, ident); lt_dlclose(handle); handle = NULL; } } else grad_log(GRAD_LOG_NOTICE, _("Cannot load module %s: %s"), name, lt_dlerror()); GRAD_DEBUG1(1,"Handle %p", handle); if (!handle) lt_dlexit(); else store_handle(handle); return handle; }
void subst(int in, int ot) { register char c; FILEBLK fb; register int count = CPYSIZ; push(&fb); initf(in); /* DQUOTE used to stop it from quoting */ while (c = (getch(DQUOTE) & STRIP)) { pushstak(c); if (--count == 0) { flush(ot); count = CPYSIZ; } } flush(ot); pop(); }
void * psc_memnode_getobj(int pos, void *(*initf)(void *), void *arg) { struct psc_memnode *pmn; void *p; pmn = psc_memnode_get(); p = psc_memnode_getkey(pmn, pos); if (p) return (p); spinlock(&pmn->pmn_lock); p = psc_memnode_getkey(pmn, pos); if (p) { freelock(&pmn->pmn_lock); return (p); } p = initf(arg); psc_memnode_setkey(pmn, pos, p); freelock(&pmn->pmn_lock); return (p); }
void forward_prob(int i, int n_mar, int n_gen, int curpos, int *cross_scheme, double error_prob, int **Geno, double **probmat, double **alpha, double initf(int, int *), double emitf(int, int, double, int *)) { /* forward equations */ /* Note: true genotypes coded as 1, 2, ... but in the alpha's and beta's, we use 0, 1, ... */ int j,v,v2; double errortol,salpha; /* initialize alpha */ /* curpos = -1: use error_prob always */ /* curpos >= 0: use TOL except when j == curpos, then use error_prob */ errortol = error_prob; if(curpos > 0) errortol = TOL; for(v=0; v<n_gen; v++) alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, errortol, cross_scheme); if(curpos == 0) errortol = TOL; for(j=1; j<n_mar; j++) { if(curpos == j) errortol = error_prob; for(v=0; v<n_gen; v++) { salpha = alpha[0][j-1] + stepfc(1, v+1, j-1, probmat); for(v2=1; v2<n_gen; v2++) salpha = addlog(salpha, alpha[v2][j-1] + stepfc(v2+1, v+1, j-1, probmat)); alpha[v][j] = salpha + emitf(Geno[j][i], v+1, errortol, cross_scheme); } if(curpos == j) errortol = TOL; } }
void est_map(int n_ind, int n_mar, int n_gen, int *geno, double *rf, double *rf2, double error_prob, double initf(int, int *), double emitf(int, int, double, int *), double stepf(int, int, double, double, int *), double nrecf1(int, int, double, int*), double nrecf2(int, int, double, int*), double *loglik, int maxit, double tol, int sexsp, int verbose) { int i, j, j2, v, v2, it, flag=0, **Geno, ndigits; double s, **alpha, **beta, **gamma, *cur_rf, *cur_rf2; double curloglik, maxdif, temp; char pattern[100], text[200]; int cross_scheme[2]; /* cross scheme hidden in loglik argument; used by hmm_bcsft */ cross_scheme[0] = (int) ftrunc(*loglik / 1000.0); cross_scheme[1] = ((int) *loglik) - 1000 * cross_scheme[0]; *loglik = 0.0; /* allocate space for beta and reorganize geno */ reorg_geno(n_ind, n_mar, geno, &Geno); allocate_alpha(n_mar, n_gen, &alpha); allocate_alpha(n_mar, n_gen, &beta); allocate_dmatrix(n_gen, n_gen, &gamma); allocate_double(n_mar-1, &cur_rf); allocate_double(n_mar-1, &cur_rf2); /* digits in verbose output */ if(verbose) { ndigits = (int)ceil(-log10(tol)); if(ndigits > 16) ndigits=16; sprintf(pattern, "%s%d.%df", "%", ndigits+3, ndigits+1); } /* begin EM algorithm */ for(it=0; it<maxit; it++) { for(j=0; j<n_mar-1; j++) { cur_rf[j] = cur_rf2[j] = rf[j]; rf[j] = 0.0; if(sexsp) { cur_rf2[j] = rf2[j]; rf2[j] = 0.0; } } for(i=0; i<n_ind; i++) { /* i = individual */ R_CheckUserInterrupt(); /* check for ^C */ /* initialize alpha and beta */ for(v=0; v<n_gen; v++) { alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme); beta[v][n_mar-1] = 0.0; } /* forward-backward equations */ for(j=1,j2=n_mar-2; j<n_mar; j++, j2--) { for(v=0; v<n_gen; v++) { alpha[v][j] = alpha[0][j-1] + stepf(1, v+1, cur_rf[j-1], cur_rf2[j-1], cross_scheme); beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,cur_rf[j2], cur_rf2[j2], cross_scheme) + emitf(Geno[j2+1][i],1,error_prob, cross_scheme); for(v2=1; v2<n_gen; v2++) { alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] + stepf(v2+1,v+1,cur_rf[j-1],cur_rf2[j-1], cross_scheme)); beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] + stepf(v+1,v2+1,cur_rf[j2],cur_rf2[j2], cross_scheme) + emitf(Geno[j2+1][i],v2+1,error_prob, cross_scheme)); } alpha[v][j] += emitf(Geno[j][i],v+1,error_prob, cross_scheme); } } for(j=0; j<n_mar-1; j++) { /* calculate gamma = log Pr(v1, v2, O) */ for(v=0, s=0.0; v<n_gen; v++) { for(v2=0; v2<n_gen; v2++) { gamma[v][v2] = alpha[v][j] + beta[v2][j+1] + emitf(Geno[j+1][i], v2+1, error_prob, cross_scheme) + stepf(v+1, v2+1, cur_rf[j], cur_rf2[j], cross_scheme); if(v==0 && v2==0) s = gamma[v][v2]; else s = addlog(s, gamma[v][v2]); } } for(v=0; v<n_gen; v++) { for(v2=0; v2<n_gen; v2++) { rf[j] += nrecf1(v+1,v2+1, cur_rf[j], cross_scheme) * exp(gamma[v][v2] - s); if(sexsp) rf2[j] += nrecf2(v+1,v2+1, cur_rf[j], cross_scheme) * exp(gamma[v][v2] - s); } } } } /* loop over individuals */ /* rescale */ for(j=0; j<n_mar-1; j++) { rf[j] /= (double)n_ind; if(rf[j] < tol/1000.0) rf[j] = tol/1000.0; else if(rf[j] > 0.5-tol/1000.0) rf[j] = 0.5-tol/1000.0; if(sexsp) { rf2[j] /= (double)n_ind; if(rf2[j] < tol/1000.0) rf2[j] = tol/1000.0; else if(rf2[j] > 0.5-tol/1000.0) rf2[j] = 0.5-tol/1000.0; } else rf2[j] = rf[j]; } if(verbose>1) { /* print estimates as we go along*/ Rprintf(" %4d ", it+1); maxdif=0.0; for(j=0; j<n_mar-1; j++) { temp = fabs(rf[j] - cur_rf[j])/(cur_rf[j]+tol*100.0); if(maxdif < temp) maxdif = temp; if(sexsp) { temp = fabs(rf2[j] - cur_rf2[j])/(cur_rf2[j]+tol*100.0); if(maxdif < temp) maxdif = temp; } /* bsy add */ if(verbose > 2) Rprintf("%d %f %f\n", j+1, cur_rf[j], rf[j]); /* bsy add */ } sprintf(text, "%s%s\n", " max rel've change = ", pattern); Rprintf(text, maxdif); } /* check convergence */ for(j=0, flag=0; j<n_mar-1; j++) { if(fabs(rf[j] - cur_rf[j]) > tol*(cur_rf[j]+tol*100.0) || (sexsp && fabs(rf2[j] - cur_rf2[j]) > tol*(cur_rf2[j]+tol*100.0))) { flag = 1; break; } } if(!flag) break; } /* end EM algorithm */ if(flag) warning("Didn't converge!\n"); /* calculate log likelihood */ *loglik = 0.0; for(i=0; i<n_ind; i++) { /* i = individual */ /* initialize alpha */ for(v=0; v<n_gen; v++) { alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme); } /* forward equations */ for(j=1; j<n_mar; j++) { for(v=0; v<n_gen; v++) { alpha[v][j] = alpha[0][j-1] + stepf(1, v+1, rf[j-1], rf2[j-1], cross_scheme); for(v2=1; v2<n_gen; v2++) alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] + stepf(v2+1,v+1,rf[j-1],rf2[j-1], cross_scheme)); alpha[v][j] += emitf(Geno[j][i],v+1,error_prob, cross_scheme); } } curloglik = alpha[0][n_mar-1]; for(v=1; v<n_gen; v++) curloglik = addlog(curloglik, alpha[v][n_mar-1]); *loglik += curloglik; } if(verbose) { if(verbose < 2) { /* print final estimates */ Rprintf(" no. iterations = %d\n", it+1); maxdif=0.0; for(j=0; j<n_mar-1; j++) { temp = fabs(rf[j] - cur_rf[j])/(cur_rf[j]+tol*100.0); if(maxdif < temp) maxdif = temp; if(sexsp) { temp = fabs(rf2[j] - cur_rf2[j])/(cur_rf2[j]+tol*100.0); if(maxdif < temp) maxdif = temp; } } sprintf(text, "%s%s\n", " max rel've change at last step = ", pattern); Rprintf(text, maxdif); } Rprintf(" loglik: %10.4lf\n\n", *loglik); } }
int test_moves() { Board b; Move *moves; int status, num_moves, expected; status = WIN; /* on startup, there shouldn't be any king moves */ setup(&b); moves = gen_moves(&b, &num_moves); expected = 20; if(num_moves != expected) { if(!QUIET) { if(to_play(&b) == WHITE) printf("\t>> WHITE to play, "); else printf("\t>> BLACK to play, "); printf("expected %d moves, but saw %d\n", expected, num_moves); printb(&b); } status = FAIL; } free(moves); /* try this config (black moves) */ initf(&b, "rnbqkbnr/pp1ppppp/8/2p5/4P3/5N2/PPPP1PPP/RNBQKB1R b KQkq - 1 2"); moves = gen_moves(&b, &num_moves); expected = 22; if(num_moves != expected) { if(!QUIET) { if(to_play(&b) == WHITE) printf("\t>> WHITE to play, "); else printf("\t>> BLACK to play, "); printf("expected %d moves, but saw %d\n", expected, num_moves); printb(&b); } status = FAIL; } free(moves); /* try this config (white moves) */ initf(&b, "rnbqkbnr/pp1ppppp/8/2p5/4P3/5N2/PPPP1PPP/RNBQKB1R b KQkq - 1 2"); set_play(&b, WHITE); moves = gen_moves(&b, &num_moves); expected = 13 + 7 + 1 + 1 + 5; /* pawns, knights, king, queen, bishop */ if(num_moves != expected) { if(!QUIET) { if(to_play(&b) == WHITE) printf("\t>> WHITE to play, "); else printf("\t>> BLACK to play, "); printf("expected %d moves, but saw %d\n", expected, num_moves); printb(&b); } status = FAIL; } free(moves); /* here is one with only rook moves */ initf(&b, "8/8/8/2r5/8/5R2/8/8 b KQkq - 1 2"); moves = gen_moves(&b, &num_moves); expected = 14; if(num_moves != expected) { if(!QUIET) { if(to_play(&b) == WHITE) printf("\t>> WHITE to play, "); else printf("\t>> BLACK to play, "); printf("expected %d moves, but saw %d\n", expected, num_moves); printb(&b); } status = FAIL; } free(moves); /* here is one with only rook moves */ initf(&b, "8/2p5/8/2r5/8/5R2/8/8 b KQkq - 1 2"); moves = gen_moves(&b, &num_moves); expected = 13; if(num_moves != expected) { if(!QUIET) { if(to_play(&b) == WHITE) printf("\t>> WHITE to play, "); else printf("\t>> BLACK to play, "); printf("expected %d moves, but saw %d\n", expected, num_moves); printb(&b); } status = FAIL; } free(moves); /* here is another one with only rook moves */ initf(&b, "8/2p5/8/2rp4/8/5R2/8/8 b KQkq - 1 2"); moves = gen_moves(&b, &num_moves); expected = 9; if(num_moves != expected) { if(!QUIET) { if(to_play(&b) == WHITE) printf("\t>> WHITE to play, "); else printf("\t>> BLACK to play, "); printf("expected %d moves, but saw %d\n", expected, num_moves); printb(&b); } status = FAIL; } free(moves); /* here is one last one with only rook moves */ initf(&b, "8/2p5/8/2rp4/8/2p2R2/8/8 b KQkq - 1 2"); moves = gen_moves(&b, &num_moves); expected = 7; if(num_moves != expected) { if(!QUIET) { if(to_play(&b) == WHITE) printf("\t>> WHITE to play, "); else printf("\t>> BLACK to play, "); printf("expected %d moves, but saw %d\n", expected, num_moves); printb(&b); } status = FAIL; } free(moves); /* and again for white... */ initf(&b, "8/2p5/8/2rp4/8/2p2R2/8/8 w KQkq - 1 2"); moves = gen_moves(&b, &num_moves); expected = 12; if(num_moves != expected) { if(!QUIET) { if(to_play(&b) == WHITE) printf("\t>> WHITE to play, "); else printf("\t>> BLACK to play, "); printf("expected %d moves, but saw %d\n", expected, num_moves); printb(&b); } status = FAIL; } free(moves); /* try to figure out bishop issue */ initf(&b, "8/3/8/2B5/8/8/8/8 w KQkq - 1 2"); moves = gen_moves(&b, &num_moves); expected = 11; if(num_moves != expected) { if(!QUIET) { if(to_play(&b) == WHITE) printf("\t>> WHITE to play, "); else printf("\t>> BLACK to play, "); printf("expected %d moves, but saw %d\n", expected, num_moves); printb(&b); } status = FAIL; } free(moves); return status; }
/* mexFunction is the gateway routine for the MEX-file. */ void mexFunction( int nlhs, mxArray *plhs[], int nrhs, const mxArray *prhs[] ) { int i, r, c, Xrows, Xcols, Lrows, Lcols; float **mfv, **X, **L, *inData, *inLib, *outData, *outMd; (void) nlhs; /* unused parameters */ (void) plhs; const mwSize *dims; mwSize number_of_dimensions; mxClassID category; /* Check to see if we are on a platform that does not support the compatibility layer. */ #if defined(_LP64) || defined (_WIN64) #ifdef MX_COMPAT_32 for (i=0; i<nrhs; i++) { if (mxIsSparse(prhs[i])) { mexErrMsgIdAndTxt("MATLAB:explore:NoSparseCompat", "MEX-files compiled on a 64-bit platform that use sparse array functions need to be compiled using -largeArrayDims."); } } #endif #endif /* check inputs */ if (nrhs != 2) { fprintf(stderr,"I need 2 inputs\n"); return; } if (mxGetNumberOfDimensions(prhs[0]) != 2) { mexPrintf("usage: mf(X,L), where each row of X is a spectrum\n"); return; } if (mxGetNumberOfDimensions(prhs[1]) != 2) { mexPrintf("usage: mf(X,L), where each row of L is a spectrum\n"); return; } category = mxGetClassID(prhs[0]); if (category != mxSINGLE_CLASS) { mexPrintf("The data matrix must have type 'single'\n"); return; } category = mxGetClassID(prhs[1]); if (category != mxSINGLE_CLASS) { mexPrintf("The library matrix must have type 'single'\n"); return; } /* Get input dimensions */ dims = mxGetDimensions(prhs[0]); Xrows = dims[0]; Xcols = dims[1]; dims = mxGetDimensions(prhs[1]); Lrows = dims[0]; Lcols = dims[1]; if (Lcols != Xcols) { mexPrintf("Dimension mismatch between library and data\n"); return; } inData = (float *) mxGetData(prhs[0]); inLib = (float *) mxGetData(prhs[1]); /* build data arrays. do MF detection, clean up */ newf(&X, Xrows, Xcols); newf(&L, Lrows, Lcols); initf(&mfv, Xrows, Lrows, 0); /* Copy matlab input arrays into X and L */ for (r=0; r<Xrows; r++) { for (c=0; c<Xcols; c++) { X[r][c] = inData[c*Xrows+r]; } } for (r=0; r<Lrows; r++) { for (c=0; c<Lcols; c++) { L[r][c] = inLib[c*Lrows+r]; } } /* create space for output */ outData = (float *) mxCalloc(Xrows*Lrows, sizeof(float)); outMd = (float *) mxCalloc(Xrows, sizeof(float)); /* call the library function for matched filter detection */ mf(X, Xrows, Xcols, L, Lrows, NEVALS, DIAG, mfv, outMd); /* copy into the output array */ for (r=0; r<Xrows; r++) { for (c=0; c<Lrows; c++) { outData[c*Xrows+r] = mfv[r][c]; } } /* clean up */ clearf(X, Xrows, Xcols); clearf(L, Lrows, Lcols); clearf(mfv, Xrows, Lrows); /* create output structure */ plhs[0] = mxCreateNumericMatrix(0, 0, mxSINGLE_CLASS, mxREAL); mxSetData(plhs[0], outData); mxSetM(plhs[0], Xrows); mxSetN(plhs[0], Lrows); if (nlhs > 1) { plhs[1] = mxCreateNumericMatrix(0, 0, mxSINGLE_CLASS, mxREAL); mxSetData(plhs[1], outMd); mxSetM(plhs[1], Xrows); mxSetN(plhs[1], 1); } else { mxFree(outMd); } }
void calc_genoprob_special(int n_ind, int n_pos, int n_gen, int *geno, double *rf, double *rf2, double error_prob, double *genoprob, double initf(int), double emitf(int, int, double), double stepf(int, int, double, double)) { int i, j, j2, v, v2, curpos; double s, **alpha, **beta; int **Geno; double ***Genoprob; /* allocate space for alpha and beta and reorganize geno and genoprob */ reorg_geno(n_ind, n_pos, geno, &Geno); reorg_genoprob(n_ind, n_pos, n_gen, genoprob, &Genoprob); allocate_alpha(n_pos, n_gen, &alpha); allocate_alpha(n_pos, n_gen, &beta); for(i=0; i<n_ind; i++) { /* i = individual */ for(curpos=0; curpos < n_pos; curpos++) { if(!Geno[curpos][i]) continue; R_CheckUserInterrupt(); /* check for ^C */ /* initialize alpha and beta */ for(v=0; v<n_gen; v++) { if(curpos==0) alpha[v][0] = initf(v+1) + emitf(Geno[0][i], v+1, error_prob); else alpha[v][0] = initf(v+1) + emitf(Geno[0][i], v+1, TOL); beta[v][n_pos-1] = 0.0; } /* forward-backward equations */ for(j=1,j2=n_pos-2; j<n_pos; j++, j2--) { for(v=0; v<n_gen; v++) { alpha[v][j] = alpha[0][j-1] + stepf(1, v+1, rf[j-1], rf2[j-1]); if(curpos==j2+1) beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,rf[j2], rf2[j2]) + emitf(Geno[j2+1][i],1,error_prob); else beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,rf[j2], rf2[j2]) + emitf(Geno[j2+1][i],1,TOL); for(v2=1; v2<n_gen; v2++) { alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] + stepf(v2+1,v+1,rf[j-1],rf2[j-1])); if(curpos==j2+1) beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] + stepf(v+1,v2+1,rf[j2],rf2[j2]) + emitf(Geno[j2+1][i],v2+1,error_prob)); else beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] + stepf(v+1,v2+1,rf[j2],rf2[j2]) + emitf(Geno[j2+1][i],v2+1,TOL)); } if(curpos==j) alpha[v][j] += emitf(Geno[j][i],v+1,error_prob); else alpha[v][j] += emitf(Geno[j][i],v+1,TOL); } } /* calculate genotype probabilities */ s = Genoprob[0][curpos][i] = alpha[0][curpos] + beta[0][curpos]; for(v=1; v<n_gen; v++) { Genoprob[v][curpos][i] = alpha[v][curpos] + beta[v][curpos]; s = addlog(s, Genoprob[v][curpos][i]); } for(v=0; v<n_gen; v++) Genoprob[v][curpos][i] = exp(Genoprob[v][curpos][i] - s); } /* end loop over current position */ } /* loop over individuals */ }
static void exfile(int prof) { time_t mailtime = 0; /* Must not be a register variable */ time_t curtime = 0; /* * move input */ if (input > 0) { Ldup(input, INIO); input = INIO; } setmode(prof); if (setjmp(errshell) && prof) { close(input); (void) endjobs(0); return; } /* * error return here */ loopcnt = peekc = peekn = 0; fndef = 0; nohash = 0; iopend = 0; if (input >= 0) initf(input); /* * command loop */ for (;;) { tdystak(0); stakchk(); /* may reduce sbrk */ exitset(); if ((flags & prompt) && standin->fstak == 0 && !eof) { if (mailp) { time(&curtime); if ((curtime - mailtime) >= mailchk) { chkmail(); mailtime = curtime; } } /* necessary to print jobs in a timely manner */ if (trapnote & TRAPSET) chktrap(); prs(ps1nod.namval); #ifdef TIME_OUT alarm(TIMEOUT); #endif } trapnote = 0; peekc = readwc(); if (eof) { if (endjobs(JOB_STOPPED)) return; eof = 0; } #ifdef TIME_OUT alarm(0); #endif { struct trenod *t; t = cmd(NL, MTFLG); if (t == NULL && flags & ttyflg) freejobs(); else execute(t, 0, eflag); } eof |= (flags & oneflg); } }
void calc_genoprob(int n_ind, int n_pos, int n_gen, int *geno, double *rf, double *rf2, double error_prob, double *genoprob, double initf(int, int *), double emitf(int, int, double, int *), double stepf(int, int, double, double, int *)) { int i, j, j2, v, v2; double s, **alpha, **beta; int **Geno; double ***Genoprob; int cross_scheme[2]; /* cross scheme hidden in genoprob argument; used by hmm_bcsft */ cross_scheme[0] = genoprob[0]; cross_scheme[1] = genoprob[1]; genoprob[0] = 0.0; genoprob[1] = 0.0; /* allocate space for alpha and beta and reorganize geno and genoprob */ reorg_geno(n_ind, n_pos, geno, &Geno); reorg_genoprob(n_ind, n_pos, n_gen, genoprob, &Genoprob); allocate_alpha(n_pos, n_gen, &alpha); allocate_alpha(n_pos, n_gen, &beta); for(i=0; i<n_ind; i++) { /* i = individual */ R_CheckUserInterrupt(); /* check for ^C */ /* initialize alpha and beta */ for(v=0; v<n_gen; v++) { alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme); beta[v][n_pos-1] = 0.0; } /* forward-backward equations */ for(j=1,j2=n_pos-2; j<n_pos; j++, j2--) { for(v=0; v<n_gen; v++) { alpha[v][j] = alpha[0][j-1] + stepf(1, v+1, rf[j-1], rf2[j-1], cross_scheme); beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,rf[j2], rf2[j2], cross_scheme) + emitf(Geno[j2+1][i],1,error_prob, cross_scheme); for(v2=1; v2<n_gen; v2++) { alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] + stepf(v2+1,v+1,rf[j-1],rf2[j-1], cross_scheme)); beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] + stepf(v+1,v2+1,rf[j2],rf2[j2], cross_scheme) + emitf(Geno[j2+1][i],v2+1,error_prob, cross_scheme)); } alpha[v][j] += emitf(Geno[j][i],v+1,error_prob, cross_scheme); } } /* calculate genotype probabilities */ for(j=0; j<n_pos; j++) { s = Genoprob[0][j][i] = alpha[0][j] + beta[0][j]; for(v=1; v<n_gen; v++) { Genoprob[v][j][i] = alpha[v][j] + beta[v][j]; s = addlog(s, Genoprob[v][j][i]); } for(v=0; v<n_gen; v++) Genoprob[v][j][i] = exp(Genoprob[v][j][i] - s); } /* the following is the old version */ /* for(j=0; j<n_pos; j++) { s = 0.0; for(v=0; v<n_gen; v++) s += (Genoprob[v][j][i] = exp(alpha[v][j] + beta[v][j])); for(v=0; v<n_gen; v++) Genoprob[v][j][i] /= s; } */ } /* loop over individuals */ }
void calc_pairprob(int n_ind, int n_pos, int n_gen, int *geno, double *rf, double *rf2, double error_prob, double *genoprob, double *pairprob, double initf(int, int *), double emitf(int, int, double, int *), double stepf(int, int, double, double, int *)) { int i, j, j2, v, v2, v3; double s=0.0, **alpha, **beta; int **Geno; double ***Genoprob, *****Pairprob; int cross_scheme[2]; /* cross scheme hidden in genoprob argument; used by hmm_bcsft */ cross_scheme[0] = genoprob[0]; cross_scheme[1] = genoprob[1]; genoprob[0] = 0.0; genoprob[1] = 0.0; /* n_pos must be at least 2, or there are no pairs! */ if(n_pos < 2) error("n_pos must be > 1 in calc_pairprob"); /* allocate space for alpha and beta and reorganize geno, genoprob, and pairprob */ reorg_geno(n_ind, n_pos, geno, &Geno); reorg_genoprob(n_ind, n_pos, n_gen, genoprob, &Genoprob); reorg_pairprob(n_ind, n_pos, n_gen, pairprob, &Pairprob); allocate_alpha(n_pos, n_gen, &alpha); allocate_alpha(n_pos, n_gen, &beta); for(i=0; i<n_ind; i++) { /* i = individual */ R_CheckUserInterrupt(); /* check for ^C */ /* initialize alpha and beta */ for(v=0; v<n_gen; v++) { alpha[v][0] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme); beta[v][n_pos-1] = 0.0; } /* forward-backward equations */ for(j=1,j2=n_pos-2; j<n_pos; j++, j2--) { for(v=0; v<n_gen; v++) { alpha[v][j] = alpha[0][j-1] + stepf(1, v+1, rf[j-1], rf2[j-1], cross_scheme); beta[v][j2] = beta[0][j2+1] + stepf(v+1,1,rf[j2], rf2[j2], cross_scheme) + emitf(Geno[j2+1][i],1,error_prob, cross_scheme); for(v2=1; v2<n_gen; v2++) { alpha[v][j] = addlog(alpha[v][j], alpha[v2][j-1] + stepf(v2+1,v+1,rf[j-1],rf2[j-1], cross_scheme)); beta[v][j2] = addlog(beta[v][j2], beta[v2][j2+1] + stepf(v+1,v2+1,rf[j2],rf2[j2], cross_scheme) + emitf(Geno[j2+1][i],v2+1,error_prob, cross_scheme)); } alpha[v][j] += emitf(Geno[j][i],v+1,error_prob, cross_scheme); } } /* calculate genotype probabilities */ for(j=0; j<n_pos; j++) { s = Genoprob[0][j][i] = alpha[0][j] + beta[0][j]; for(v=1; v<n_gen; v++) { Genoprob[v][j][i] = alpha[v][j] + beta[v][j]; s = addlog(s, Genoprob[v][j][i]); } for(v=0; v<n_gen; v++) Genoprob[v][j][i] = exp(Genoprob[v][j][i] - s); } /* calculate Pr(G[j], G[j+1] | marker data) for i = 1...n_pos-1 */ for(j=0; j<n_pos-1; j++) { for(v=0; v<n_gen; v++) { for(v2=0; v2<n_gen; v2++) { Pairprob[v][v2][j][j+1][i] = alpha[v][j] + beta[v2][j+1] + stepf(v+1,v2+1,rf[j],rf2[j], cross_scheme) + emitf(Geno[j+1][i],v2+1,error_prob, cross_scheme); if(v==0 && v2==0) s=Pairprob[v][v2][j][j+1][i]; else s = addlog(s,Pairprob[v][v2][j][j+1][i]); } } /* scale to sum to 1 */ for(v=0; v<n_gen; v++) for(v2=0; v2<n_gen; v2++) Pairprob[v][v2][j][j+1][i] = exp(Pairprob[v][v2][j][j+1][i] - s); } /* now calculate Pr(G[i], G[j] | marker data) for j > i+1 */ for(j=0; j<n_pos-2; j++) { for(j2=j+2; j2<n_pos; j2++) { for(v=0; v<n_gen; v++) { /* genotype at pos'n j */ for(v2=0; v2<n_gen; v2++) { /* genotype at pos'n j2 */ Pairprob[v][v2][j][j2][i] = 0.0; for(v3=0; v3<n_gen; v3++) { /* genotype at pos'n j2-1 */ s = Genoprob[v3][j2-1][i]; if(fabs(s) > TOL) /* avoid 0/0 */ Pairprob[v][v2][j][j2][i] += Pairprob[v][v3][j][j2-1][i]* Pairprob[v3][v2][j2-1][j2][i]/s; } } } /* end loops over genotypes */ } } /* end loops over pairs of positions */ } /* end loop over individuals */ }
void argmax_geno(int n_ind, int n_pos, int n_gen, int *geno, double *rf, double *rf2, double error_prob, int *argmax, double initf(int, int *), double emitf(int, int, double, int *), double stepf(int, int, double, double, int *)) { int i, j, v, v2; double s, t, *gamma, *tempgamma, *tempgamma2; int **Geno, **Argmax, **traceback; int cross_scheme[2]; /* cross scheme hidden in argmax argument; used by hmm_bcsft */ cross_scheme[0] = argmax[0]; cross_scheme[1] = argmax[1]; argmax[0] = geno[0]; argmax[1] = geno[1]; /* Read R's random seed */ /* in the case of multiple "most likely" genotype sequences, we pick from them at random */ GetRNGstate(); /* allocate space and reorganize geno and argmax */ reorg_geno(n_ind, n_pos, geno, &Geno); reorg_geno(n_ind, n_pos, argmax, &Argmax); allocate_imatrix(n_pos, n_gen, &traceback); allocate_double(n_gen, &gamma); allocate_double(n_gen, &tempgamma); allocate_double(n_gen, &tempgamma2); for(i=0; i<n_ind; i++) { /* i = individual */ R_CheckUserInterrupt(); /* check for ^C */ /* begin viterbi algorithm */ if(n_pos > 1) { /* multiple markers */ for(v=0; v<n_gen; v++) gamma[v] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme); for(j=0; j<n_pos-1; j++) { for(v=0; v<n_gen; v++) { tempgamma[v] = s = gamma[0] + stepf(1, v+1, rf[j], rf2[j], cross_scheme); traceback[j][v] = 0; for(v2=1; v2<n_gen; v2++) { t = gamma[v2] + stepf(v2+1, v+1, rf[j], rf2[j], cross_scheme); if(t > s || (fabs(t-s) < TOL && unif_rand() < 0.5)) { tempgamma[v] = s = t; traceback[j][v] = v2; } } tempgamma2[v] = tempgamma[v] + emitf(Geno[j+1][i], v+1, error_prob, cross_scheme); } for(v=0; v<n_gen; v++) gamma[v] = tempgamma2[v]; } /* finish off viterbi and then traceback to get most likely sequence of genotypes */ Argmax[n_pos-1][i] = 0; s = gamma[0]; for(v=1; v<n_gen; v++) { if(gamma[v] > s || (fabs(gamma[v]-s) < TOL && unif_rand() < 0.5)) { s = gamma[v]; Argmax[n_pos-1][i] = v; } } for(j=n_pos-2; j >= 0; j--) Argmax[j][i] = traceback[j][Argmax[j+1][i]]; } else { /* for exactly one marker */ s = initf(1, cross_scheme) + emitf(Geno[0][i], 1, error_prob, cross_scheme); Argmax[0][i] = 0; for(v=1; v<n_gen; v++) { t = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme); if(t > s || (fabs(t-s) < TOL && unif_rand() < 0.5)) { s = t; Argmax[0][i] = v; } } } /* code genotypes as 1, 2, ... */ for(j=0; j<n_pos; j++) Argmax[j][i]++; } /* loop over individuals */ /* write R's random seed */ PutRNGstate(); }
static void exfile(BOOL prof) { register L_INT mailtime = 0; register int userid; struct stat statb; /* move input */ if (input > 0) { Ldup(input, INIO); input = INIO; } /* move output to safe place */ if (output == 2) { Ldup(dup(2), OTIO); output = OTIO; } userid = getuid(); /* decide whether interactive */ if ((flags & intflg) || ((flags & oneflg) == 0 && isatty(output) && isatty(input))) { dfault(&ps1nod, (userid ? stdprompt : supprompt)); dfault(&ps2nod, readmsg); flags |= ttyflg | prompt; ignsig(KILL); } else { flags |= prof; flags &= ~prompt; } if (setjmp(errshell) && prof) { close(input); return; } /* error return here */ loopcnt = breakcnt = peekc = 0; iopend = 0; if (input >= 0) initf(input); /* command loop */ for (;;) { tdystak(0); stakchk(); /* may reduce sbrk */ exitset(); if ((flags & prompt) && standin->fstak == 0 && !eof) { if (mailnod.namval && stat(mailnod.namval, &statb) >= 0 && statb.st_size && (statb.st_mtime != mailtime) && mailtime) { prs(mailmsg); } mailtime = statb.st_mtime; prs(ps1nod.namval); alarm(TIMEOUT); flags |= waiting; } trapnote = 0; peekc = readc(); if (eof) return; alarm(0); flags &= ~waiting; execute(cmd(NL, MTFLG), 0, NULL, NULL); eof |= (flags & oneflg); } }
void sim_geno(int n_ind, int n_pos, int n_gen, int n_draws, int *geno, double *rf, double *rf2, double error_prob, int *draws, double initf(int, int *), double emitf(int, int, double, int *), double stepf(int, int, double, double, int *)) { int i, k, j, v, v2; double s, **beta, *probs; int **Geno, ***Draws, curstate; int cross_scheme[2]; /* cross scheme hidden in draws argument; used by hmm_bcsft */ cross_scheme[0] = draws[0]; cross_scheme[1] = draws[1]; draws[0] = 0; draws[1] = 0; /* allocate space for beta and reorganize geno and draws */ /* Geno indexed as Geno[pos][ind] */ /* Draws indexed as Draws[rep][pos][ind] */ reorg_geno(n_ind, n_pos, geno, &Geno); reorg_draws(n_ind, n_pos, n_draws, draws, &Draws); allocate_alpha(n_pos, n_gen, &beta); allocate_double(n_gen, &probs); /* Read R's random seed */ GetRNGstate(); for(i=0; i<n_ind; i++) { /* i = individual */ R_CheckUserInterrupt(); /* check for ^C */ /* do backward equations */ /* initialize beta */ for(v=0; v<n_gen; v++) beta[v][n_pos-1] = 0.0; /* backward equations */ for(j=n_pos-2; j>=0; j--) { for(v=0; v<n_gen; v++) { beta[v][j] = beta[0][j+1] + stepf(v+1,1,rf[j], rf2[j], cross_scheme) + emitf(Geno[j+1][i],1,error_prob, cross_scheme); for(v2=1; v2<n_gen; v2++) beta[v][j] = addlog(beta[v][j], beta[v2][j+1] + stepf(v+1,v2+1,rf[j],rf2[j], cross_scheme) + emitf(Geno[j+1][i],v2+1,error_prob, cross_scheme)); } } for(k=0; k<n_draws; k++) { /* k = simulation replicate */ /* first draw */ /* calculate probs */ s = (probs[0] = initf(1, cross_scheme)+emitf(Geno[0][i],1,error_prob, cross_scheme)+beta[0][0]); for(v=1; v<n_gen; v++) { probs[v] = initf(v+1, cross_scheme) + emitf(Geno[0][i], v+1, error_prob, cross_scheme) + beta[v][0]; s = addlog(s, probs[v]); } for(v=0; v<n_gen; v++) probs[v] = exp(probs[v] - s); /* make draw: returns a value from {1, 2, ..., n_gen} */ curstate = Draws[k][0][i] = sample_int(n_gen, probs); /* move along chromosome */ for(j=1; j<n_pos; j++) { /* calculate probs */ for(v=0; v<n_gen; v++) probs[v] = exp(stepf(curstate,v+1,rf[j-1],rf2[j-1], cross_scheme) + emitf(Geno[j][i],v+1,error_prob, cross_scheme) + beta[v][j] - beta[curstate-1][j-1]); /* make draw */ curstate = Draws[k][j][i] = sample_int(n_gen, probs); } } /* loop over replicates */ } /* loop over individuals */ /* write R's random seed */ PutRNGstate(); }
int udl_load( const char *pname ) { FILE *fp; char *pdata; int id; u32 temp; char ctemp[ UDL_MAX_LTR_SYMNAME + 1 ]; udl_module_data *m; udl_module_data tmpm; udl_debug( "Loading module %s\n", pname ); if( ( fp = fopen( pname, "rb" ) ) == NULL ) { udl_debug( "Cannot read module from file %s\n", pname ); return UDL_INVALID_MODULE; } // Read hash fread( &tmpm.hash, 1, 4, fp ); // Read signature fread( &temp, 1, 4, fp ); if( temp != UDL_MOD_SIGN ) { udl_debug( "Invalid module signature\n" ); fclose( fp ); return UDL_INVALID_MODULE; } // Read module data fread( &tmpm.total, 1, 4, fp ); fread( &tmpm.offset, 1, 4, fp ); udl_debug( "module size: %u offset: %08X\n", ( unsigned )tmpm.total, ( unsigned )tmpm.offset ); // Read module name (fixed size always) fread( ctemp, 1, UDL_MAX_MOD_NAME, fp ); udl_debug( "module name: %s\n", ctemp ); // Now it's a good time to check if the module is already loaded if( ( id = udlh_slot_from_name( ctemp ) ) != -1 ) { udl_debug( "Module %s already loaded.\n", ctemp ); if( udl_modules[ id ].hash == tmpm.hash ) { udl_debug( "Modules are identical, incrementing reference count.\n" ); udl_modules[ id ].refcount ++; } else { udl_debug( "Another version of '%s' is already loaded, unable to load the new module.\n", ctemp ); id = UDL_VERSION_ERROR; } fclose( fp ); return id; } else { if( ( id = udlh_find_slot() ) == -1 ) { udl_debug( "No slots available\n" ); fclose( fp ); return UDL_NO_SLOTS; } } m = udl_modules + id; *m = tmpm; m->refcount = 1; udl_debug( "Will load module at slot %d\n", id ); // Read all data now if( ( pdata = ( char* )malloc( m->total + UDL_MAX_MOD_NAME ) ) == NULL ) { udl_debug( "Not enough memory\n" ); fclose( fp ); return UDL_OUT_OF_MEMORY; } m->data = pdata; memcpy( pdata, ctemp, UDL_MAX_MOD_NAME ); pdata += UDL_MAX_MOD_NAME; if( fread( pdata, 1, m->total, fp ) != m->total ) { udl_debug( "Unable to read %u bytes from file\n", ( unsigned )m->total ); fclose( fp ); udlh_free_slot( id ); return UDL_INVALID_MODULE; } fclose( fp ); // Is this a LTR-compatible Lua module? // It needs two symbols for this: luaopen_<modname> and <modname>_map strcpy( ctemp, "luaopen_" ); strncat( ctemp, ( const char* )m->data, UDL_MAX_LTR_SYMNAME ); udl_rotables[ id ] = 0; if( udl_find_symbol( id, ctemp ) ) { strncpy( ctemp, ( const char* )m->data, UDL_MAX_LTR_SYMNAME ); strncat( ctemp, "_map", UDL_MAX_LTR_SYMNAME ); if( ( temp = udl_find_symbol( id, ctemp ) ) != 0 ) { udl_debug( "This is a LTR module\n" ); // Save the adress of module's rotable in udl_rotables udl_rotables[ id ] = temp; udl_debug( "ROMTABLE at %X\n", ( unsigned )udl_rotables[ id ] ); } } #if 0 && defined( UDL_DEBUG ) // Dump symbol table printf( "Symbol table: \n" ); pdata = m->data + UDL_MAX_MOD_NAME; while( 1 ) { if( *pdata == '\0' ) { pdata ++; break; } printf( " name: %s\t\t ", pdata ); pdata += strlen( pdata ) + 1; pdata = ( char* )( ( ( u32 )pdata + 3 ) & ~3 ); printf( "offset: %08X\n", ( unsigned )*( u32* )pdata ); pdata += 4; } pdata = ( char* )( ( ( u32 )pdata + 3 ) & ~3 ); #endif // If the module has an init function, call it now if( ( temp = udl_find_symbol( id, UDL_MOD_INIT_FNAME ) ) != 0 ) { p_udl_init_func initf = ( p_udl_init_func )temp; if( initf( id ) == 0 ) { udl_debug( "The module init function returned 0, unloading module.\n" ); udlh_free_slot( id ); return UDL_INIT_ERROR; } } else udl_debug( "the module doesn't have an init function.\n" ); // Return module slot return id; }
int readvar(unsigned char **names) { struct fileblk fb; register struct fileblk *f = &fb; unsigned char c[MULTI_BYTE_MAX+1]; register int rc = 0; struct namnod *n; unsigned char *rel; unsigned char *oldstak; register unsigned char *pc, *rest; int d; unsigned int (*newwc)(void); extern const char badargs[]; if (eq(*names, "-r")) { if (*++names == NULL) error(badargs); newwc = readwc; } else newwc = nextwc; n = lookup(*names++); /* done now to avoid storage mess */ rel = (unsigned char *)relstak(); push(f); initf(dup(0)); /* * If stdin is a pipe then this lseek(2) will fail with ESPIPE, so * the read buffer size is set to 1 because we will not be able * lseek(2) back towards the beginning of the file, so we have * to read a byte at a time instead * */ if (lseek(0, (off_t)0, SEEK_CUR) == -1) f->fsiz = 1; #ifdef __sun /* * If stdin is a socket then this isastream(3C) will return 1, so * the read buffer size is set to 1 because we will not be able * lseek(2) back towards the beginning of the file, so we have * to read a byte at a time instead * */ if (isastream(0) == 1) f->fsiz = 1; #endif /* * strip leading IFS characters */ for (;;) { d = newwc(); if(eolchar(d)) break; rest = readw(d); pc = c; while(*pc++ = *rest++); if(!anys(c, ifsnod.namval)) break; } oldstak = curstak(); for (;;) { if ((*names && anys(c, ifsnod.namval)) || eolchar(d)) { if (staktop >= brkend) growstak(staktop); zerostak(); assign(n, absstak(rel)); setstak(rel); if (*names) n = lookup(*names++); else n = 0; if (eolchar(d)) { break; } else /* strip imbedded IFS characters */ while(1) { d = newwc(); if(eolchar(d)) break; rest = readw(d); pc = c; while(*pc++ = *rest++); if(!anys(c, ifsnod.namval)) break; } } else { if(d == '\\' && newwc == nextwc) { d = newwc(); rest = readw(d); while(d = *rest++) { if (staktop >= brkend) growstak(staktop); pushstak(d); } oldstak = staktop; } else { pc = c; while(d = *pc++) { if (staktop >= brkend) growstak(staktop); pushstak(d); } if(!anys(c, ifsnod.namval)) oldstak = staktop; } d = newwc(); if (eolchar(d)) staktop = oldstak; else { rest = readw(d); pc = c; while(*pc++ = *rest++); } } } while (n) { assign(n, nullstr); if (*names) n = lookup(*names++); else n = 0; } if (eof) rc = 1; #ifdef __sun if (isastream(0) != 1) #endif /* * If we are reading on a stream do not attempt to * lseek(2) back towards the start because this is * logically meaningless, but there is nothing in * the standards to pervent the stream implementation * from attempting it and breaking our code here * */ lseek(0, (off_t)(f->nxtoff - f->endoff), SEEK_CUR); pop(); return(rc); }