/********************************************************************** * reallocate_individual **********************************************************************/ void reallocate_individual(struct individual *ind, int old_max_seg, int new_max_seg) { int j; (*ind).max_segments = new_max_seg; (*ind).allele[0] = (int *)S_realloc((char *)(*ind).allele[0], 2*new_max_seg, 2*old_max_seg, sizeof(int)); (*ind).allele[1] = (*ind).allele[0] + new_max_seg; for(j=0; j<old_max_seg; j++) (*ind).allele[1][j] = (*ind).allele[0][old_max_seg+j]; (*ind).xoloc[0] = (double *)S_realloc((char *)(*ind).xoloc[0], 2*(new_max_seg-1), 2*(old_max_seg-1), sizeof(double)); (*ind).xoloc[1] = (*ind).xoloc[0] + new_max_seg-1; for(j=0; j<old_max_seg-1; j++) (*ind).xoloc[1][j] = (*ind).xoloc[0][old_max_seg-1+j]; }
SEXP rmysql_escape_strings(SEXP conHandle, SEXP strings) { MYSQL* con = RS_DBI_getConnection(conHandle)->drvConnection; int n = length(strings); SEXP output = PROTECT(allocVector(STRSXP, n)); long size = 100; char* escaped = S_alloc(size, sizeof(escaped)); for(int i = 0; i < n; i++){ const char* string = CHAR(STRING_ELT(strings, i)); size_t len = strlen(string); if (size <= 2 * len + 1) { escaped = S_realloc(escaped, (2 * len + 1), size, sizeof(escaped)); size = 2 * len + 1; } if (escaped == NULL) { UNPROTECT(1); error("Could not allocate memory to escape string"); } mysql_real_escape_string(con, escaped, string, len); SET_STRING_ELT(output, i, mkChar(escaped)); } UNPROTECT(1); return output; }
/* R_allocs or mallocs global arrays */ static Rboolean add_point(double x, double y, pGEDevDesc dd) { if (npoints >= max_points) { int tmp_n; double *tmp_px; double *tmp_py; tmp_n = max_points + 200; /* too many points, return false */ if (tmp_n > MAXNUMPTS) { error(_("add_point - reached MAXNUMPTS (%d)"),tmp_n); } if (max_points == 0) { tmp_px = (double *) R_alloc(tmp_n, sizeof(double)); tmp_py = (double *) R_alloc(tmp_n, sizeof(double)); } else { tmp_px = (double *) S_realloc((char *) xpoints, tmp_n, max_points, sizeof(double)); tmp_py = (double *) S_realloc((char *) ypoints, tmp_n, max_points, sizeof(double)); } if (tmp_px == NULL || tmp_py == NULL) { error(_("insufficient memory to allocate point array")); } xpoints = tmp_px; ypoints = tmp_py; max_points = tmp_n; } /* ignore identical points */ if (npoints > 0 && xpoints[npoints-1] == x && ypoints[npoints-1] == y) return TRUE; /* * Convert back from 1200ppi to DEVICE coordinates */ xpoints[npoints] = toDeviceX(x / 1200, GE_INCHES, dd); ypoints[npoints] = toDeviceY(y / 1200, GE_INCHES, dd); npoints = npoints + 1; return TRUE; }
void similarity_ordinal(double *x, int n, int p, double *S) { int i, j, k, l, npairs = n * (n - 1)/2, hj, n2 = R_pow_di(n,2), n4 = R_pow_di(n,4), incr; double mean, var, sd, sum1, sum2; double *s = (double *)R_alloc(npairs, sizeof(double)); int old = BLOCK_SIZE; int *m = (int *)R_alloc(old, sizeof(int)); for(j = 0 ; j < p ; j++) { /* similarity per variable */ l=0; for (i = 0 ; i < n ; i++) for (k = i+1 ; k < n ; k++) s[l++] = fabs(x[i + n*j] - x[k + n*j]); /* number of categories for column j */ R_rsort (x + n*j, n); hj=0; m[hj] = 1; for (i = 0 ; i < n-1 ; i++) if (x[i + n*j] == x[i + 1 + n*j]) m[hj]++; else { incr = x[i + 1 + n*j] - x[i + n*j]; if (hj + incr >= old) { m = (int *)S_realloc((char *)m, old + BLOCK_SIZE, old, sizeof(int)); old += BLOCK_SIZE; } for (k=1;k<incr;k++) m[hj+k] = 0; hj += incr; m[hj] = 1; } hj++; /* computation of the expectation and the variance */ sum1 = 0.0; sum2 = 0.0; for (i = 0 ; i < hj ; i++) for (k = 0 ; k < i ; k++) { sum1 += m[i] * m[k] * (i - k); sum2 += m[i] * m[k] * R_pow_di(i - k,2); } mean = hj - 1.0 - 2.0/n2 * sum1; var = 2.0/n2 * sum2 - 4.0/n4 * R_pow_di(sum1,2); sd = sqrt(var); for (l = 0 ; l < npairs; l++) S[l] += (hj - 1.0 - s[l] - mean)/sd; } }
/* Convert R "mpfr" object (list of "mpfr1") to R "character" vector, * using precision 'prec' which can be NA/NULL in which case * "full precision" (as long as necessary) is used : */ SEXP mpfr2str(SEXP x, SEXP digits, SEXP base) { int n = length(x), i; int n_dig = isNull(digits) ? 0 : asInteger(digits); int dig_n_max = -1; SEXP val = PROTECT(allocVector(VECSXP, 4)), nms, str, exp, fini, zero; int *i_exp, *is_fin, *is_0; int B = asInteger(base); // = base for output double p_fact = (B == 2) ? 1. : log(B) / M_LN2; char *ch = NULL; mpfr_t R_i; if(n_dig < 0) error("'digits' must be NULL or integer >= 0"); /* be "overprotective" for now ... */ SET_VECTOR_ELT(val, 0, str = PROTECT(allocVector(STRSXP, n))); SET_VECTOR_ELT(val, 1, exp = PROTECT(allocVector(INTSXP, n))); SET_VECTOR_ELT(val, 2, fini= PROTECT(allocVector(LGLSXP, n))); SET_VECTOR_ELT(val, 3, zero= PROTECT(allocVector(LGLSXP, n))); nms = PROTECT(allocVector(STRSXP, 4)); SET_STRING_ELT(nms, 0, mkChar("str")); SET_STRING_ELT(nms, 1, mkChar("exp")); SET_STRING_ELT(nms, 2, mkChar("finite")); SET_STRING_ELT(nms, 3, mkChar("is.0")); setAttrib(val, R_NamesSymbol, nms); i_exp = INTEGER(exp); is_fin= LOGICAL(fini); is_0 = LOGICAL(zero); mpfr_init(R_i); /* with default precision */ for(i=0; i < n; i++) { mpfr_exp_t exp = (mpfr_exp_t) 0; mpfr_exp_t *exp_ptr = &exp; int dig_needed; R_asMPFR(VECTOR_ELT(x, i), R_i); #ifdef __Rmpfr_FIRST_TRY_FAILS__ /* Observing memory problems, e.g., see ../tests/00-bug.R.~3~ * Originally hoped it was solvable via R_alloc() etc, but it seems the problem is * deeper and I currently suspect a problem/bug in MPFR library's mpfr_get_str(..) */ ch = mpfr_get_str(NULL, exp_ptr, B, (size_t) n_dig, R_i, MPFR_RNDN); #else if(n_dig) {/* use it as desired precision */ dig_needed = n_dig; } else { /* n_dig = 0 --> string will use "enough" digits */ dig_needed = p_fact * (int)R_i->_mpfr_prec; } if (i == 0) { /* first time */ dig_n_max = dig_needed; ch = (char *) R_alloc(dig_needed + 2, sizeof(char)); } else if(!n_dig && dig_needed > dig_n_max) { ch = (char *) S_realloc(ch, dig_needed + 2, dig_n_max + 2, sizeof(char)); dig_n_max = dig_needed; } /* char * mpfr_get_str (char *STR, mpfr_exp_t *EXPPTR, int B, * size_t N, mpfr_t OP, mpfr_rnd_t RND) */ mpfr_get_str(ch, exp_ptr, B, (size_t) n_dig, R_i, MPFR_RNDN); #endif SET_STRING_ELT(str, i, mkChar(ch)); i_exp[i] = (int) exp_ptr[0]; is_fin[i]= mpfr_number_p(R_i); is_0 [i] = mpfr_zero_p(R_i); #ifdef __Rmpfr_FIRST_TRY_FAILS__ mpfr_free_str(ch); #endif } mpfr_clear (R_i); mpfr_free_cache(); UNPROTECT(6); return val; }
SEXP thinjumpequal(SEXP n, SEXP p, SEXP guess) { int N; double P; int *w; /* temporary storage for selected integers */ int nw, nwmax; int i, j, k; double log1u, log1p; /* R object return value */ SEXP Out; /* external storage pointer */ int *OutP; /* protect R objects from garbage collector */ PROTECT(p = AS_NUMERIC(p)); PROTECT(n = AS_INTEGER(n)); PROTECT(guess = AS_INTEGER(guess)); /* Translate arguments from R to C */ N = *(INTEGER_POINTER(n)); P = *(NUMERIC_POINTER(p)); nwmax = *(INTEGER_POINTER(guess)); /* Allocate space for result */ w = (int *) R_alloc(nwmax, sizeof(int)); /* set up */ GetRNGstate(); log1p = -log(1.0 - P); /* main loop */ i = 0; /* last selected element of 1...N */ nw = 0; /* number of selected elements */ while(i <= N) { log1u = exp_rand(); /* an exponential rv is equivalent to -log(1-U) */ j = (int) ceil(log1u/log1p); /* j is geometric(p) */ i += j; if(nw >= nwmax) { /* overflow; allocate more space */ w = (int *) S_realloc((char *) w, 2 * nwmax, nwmax, sizeof(int)); nwmax = 2 * nwmax; } /* add 'i' to output vector */ w[nw] = i; ++nw; } /* The last saved 'i' could have exceeded 'N' */ /* For efficiency we don't check this in the loop */ if(nw > 0 && w[nw-1] > N) --nw; PutRNGstate(); /* create result vector */ PROTECT(Out = NEW_INTEGER(nw)); /* copy results into output */ OutP = INTEGER_POINTER(Out); for(k = 0; k < nw; k++) OutP[k] = w[k]; UNPROTECT(4); return(Out); }
SEXP actuar_do_panjer(SEXP args) { SEXP p0, p1, fs0, sfx, a, b, conv, tol, maxit, echo, sfs; double *fs, *fx, cumul; int upper, m, k, n, x = 1; double norm; /* normalizing constant */ double term; /* constant in the (a, b, 1) case */ /* The length of vector fs is not known in advance. We opt for a * simple scheme: allocate memory for a vector of size 'size', * double the size when the vector is full. */ int size = INITSIZE; fs = (double *) S_alloc(size, sizeof(double)); /* All values received from R are then protected. */ PROTECT(p0 = coerceVector(CADR(args), REALSXP)); PROTECT(p1 = coerceVector(CADDR(args), REALSXP)); PROTECT(fs0 = coerceVector(CADDDR(args), REALSXP)); PROTECT(sfx = coerceVector(CAD4R(args), REALSXP)); PROTECT(a = coerceVector(CAD5R(args), REALSXP)); PROTECT(b = coerceVector(CAD6R(args), REALSXP)); PROTECT(conv = coerceVector(CAD7R(args), INTSXP)); PROTECT(tol = coerceVector(CAD8R(args), REALSXP)); PROTECT(maxit = coerceVector(CAD9R(args), INTSXP)); PROTECT(echo = coerceVector(CAD10R(args), LGLSXP)); /* Initialization of some variables */ fx = REAL(sfx); /* severity distribution */ upper = length(sfx) - 1; /* severity distribution support upper bound */ fs[0] = REAL(fs0)[0]; /* value of Pr[S = 0] (computed in R) */ cumul = REAL(fs0)[0]; /* cumulative probability computed */ norm = 1 - REAL(a)[0] * fx[0]; /* normalizing constant */ n = INTEGER(conv)[0]; /* number of convolutions to do */ /* If printing of recursions was asked for, start by printing a * header and the probability at 0. */ if (LOGICAL(echo)[0]) Rprintf("x\tPr[S = x]\tCumulative probability\n%d\t%.8g\t%.8g\n", 0, fs[0], fs[0]); /* (a, b, 0) case (if p0 is NULL) */ if (isNull(CADR(args))) do { /* Stop after 'maxit' recursions and issue warning. */ if (x > INTEGER(maxit)[0]) { warning(_("maximum number of recursions reached before the probability distribution was complete")); break; } /* If fs is too small, double its size */ if (x >= size) { fs = (double *) S_realloc((char *) fs, size << 1, size, sizeof(double)); size = size << 1; } m = x; if (x > upper) m = upper; /* upper bound of the sum */ /* Compute probability up to the scaling constant */ for (k = 1; k <= m; k++) fs[x] += (REAL(a)[0] + REAL(b)[0] * k / x) * fx[k] * fs[x - k]; fs[x] = fs[x]/norm; /* normalization */ cumul += fs[x]; /* cumulative sum */ if (LOGICAL(echo)[0]) Rprintf("%d\t%.8g\t%.8g\n", x, fs[x], cumul); x++; } while (cumul < REAL(tol)[0]); /* (a, b, 1) case (if p0 is non-NULL) */ else { /* In the (a, b, 1) case, the recursion formula has an * additional term involving f_X(x). The mathematical notation * assumes that f_X(x) = 0 for x > m (the maximal value of the * distribution). We need to treat this specifically in * programming, though. */ double fxm; /* Constant term in the (a, b, 1) case. */ term = (REAL(p1)[0] - (REAL(a)[0] + REAL(b)[0]) * REAL(p0)[0]); do { /* Stop after 'maxit' recursions and issue warning. */ if (x > INTEGER(maxit)[0]) { warning(_("maximum number of recursions reached before the probability distribution was complete")); break; } if (x >= size) { fs = (double *) S_realloc((char *) fs, size << 1, size, sizeof(double)); size = size << 1; } m = x; if (x > upper) { m = upper; /* upper bound of the sum */ fxm = 0.0; /* i.e. no additional term */ } else fxm = fx[m]; /* i.e. additional term */ for (k = 1; k <= m; k++) fs[x] += (REAL(a)[0] + REAL(b)[0] * k / x) * fx[k] * fs[x - k]; fs[x] = (fs[x] + fxm * term) / norm; cumul += fs[x]; if (LOGICAL(echo)[0]) Rprintf("%d\t%.8g\t%.8g\n", x, fs[x], cumul); x++; } while (cumul < REAL(tol)[0]); } /* If needed, convolve the distribution obtained above with itself * using a very simple direct technique. Since we want to * continue storing the distribution in array 'fs', we need to * copy the vector in an auxiliary array at each convolution. */ if (n) { int i, j, ox; double *ofs; /* auxiliary array */ /* Resize 'fs' to its final size after 'n' convolutions. Each * convolution increases the length from 'x' to '2 * x - 1'. */ fs = (double *) S_realloc((char *) fs, (1 << n) * (x - 1) + 1, size, sizeof(double)); /* Allocate enough memory in the auxiliary array for the 'n' * convolutions. This is just slightly over half the final * size of 'fs'. */ ofs = (double *) S_alloc((1 << (n - 1)) * (x - 1) + 1, sizeof(double)); for (k = 0; k < n; k++) { memcpy(ofs, fs, x * sizeof(double)); /* keep previous array */ ox = x; /* previous array length */ x = (x << 1) - 1; /* new array length */ for(i = 0; i < x; i++) fs[i] = 0.0; for(i = 0; i < ox; i++) for(j = 0; j < ox; j++) fs[i + j] += ofs[i] * ofs[j]; } } /* Copy the values of fs to a SEXP which will be returned to R. */ PROTECT(sfs = allocVector(REALSXP, x)); memcpy(REAL(sfs), fs, x * sizeof(double)); UNPROTECT(11); return(sfs); }
/********************************************************************** * * meiosis * * chrlen Chromosome length (in cM) * * m interference parameter (0 corresponds to no interference) * * p for stahl model, proportion of chiasmata from NI mechanism * * maxwork * work * * n_xo * **********************************************************************/ void meiosis(double L, int m, double p, int *maxwork, double **work, int *n_xo) { int i, n, nn, j, first; if(m > 0 && p < 1.0) { /* crossover interference */ /* simulate number of XOs and intermediates */ n = (int)rpois(L*(double)(m+1)/50.0*(1.0-p)); if(n > *maxwork) { /* need a bigger workspace */ *work = (double *)S_realloc((char *)*work, n*2, *maxwork, sizeof(double)); *maxwork = n*2; } for(i=0; i<n; i++) (*work)[i] = L*unif_rand(); /* sort them */ R_rsort(*work, n); /* which is the first crossover? */ first = random_int(0,m); for(i=first, j=0; i<n; i += (m+1), j++) (*work)[j] = (*work)[i]; n = j; /* thin with probability 1/2 */ for(i=0, j=0; i<n; i++) { if(unif_rand() < 0.5) { (*work)[j] = (*work)[i]; j++; } } n = j; nn = (int) rpois(L*p/100.0); if(n +nn > *maxwork) { /* need a bigger workspace */ *work = (double *)S_realloc((char *)*work, (n+nn)*2, *maxwork, sizeof(double)); *maxwork = (n+nn)*2; } for(i=0; i<nn; i++) (*work)[i+n] = L*unif_rand(); R_rsort(*work, n+nn); *n_xo = n+nn; } else { /* no crossover interference */ n = (int) rpois(L/100.0); if(n > *maxwork) { /* need a bigger workspace */ *work = (double *)S_realloc((char *)*work, n*2, *maxwork, sizeof(double)); *maxwork = n*2; } for(i=0; i<n; i++) (*work)[i] = L*unif_rand(); /* sort them */ R_rsort(*work, n); *n_xo = n; } }
/* version when nu = m+1 is an integer * * m = interference parameter (m=0 gives no interference) * p = proportion of chiasmata from no interference process * L = length of chromosome (in cM) * Lstar = revised length for simulating numbers of chiasmata, for case of obligate chiasma * on same scale as L * nxo = on output, the number of crossovers * Loc = on output, the locations of the crossovers * max_nxo = maximum no. crossovers allowed (length of loc) * obligate_chiasma = 1 if require at least one chiasma (0 otherwise) * */ void simStahl_int(int n_sim, int m, double p, double L, double Lstar, int *nxo, double **Loc, int max_nxo, int obligate_chiasma) { int i, j, k, n_nichi, n_pts, n_ichi, first, max_pts; double *ptloc; double lambda1, lambda2; /* space for locations of chiasmata and intermediate pts */ max_pts = 2*max_nxo*(m+1); ptloc = (double *)R_alloc(max_pts, sizeof(double)); GetRNGstate(); if(m==0) { /* looks like a Poisson model */ for(i=0; i< n_sim; i++) { R_CheckUserInterrupt(); /* check for ^C */ if(obligate_chiasma) { /* no. chiasmata, required >= 1 */ while((n_ichi = rpois(Lstar/50.0)) == 0); /* no crossovers by thinning 1/2 */ nxo[i] = rbinom((double)n_ichi, 0.5); } else nxo[i] = rpois(Lstar/100.0); if(nxo[i] > max_nxo) error("Exceeded maximum number of crossovers."); for(j=0; j < nxo[i]; j++) Loc[i][j] = runif(0.0, L); } } else { lambda1 = Lstar/50.0 * (m+1) * (1.0 - p); lambda2 = Lstar/50.0 * p; for(i=0; i< n_sim; i++) { while(1) { R_CheckUserInterrupt(); /* check for ^C */ /* simulate no. chiasmata + intermediate pts from interference process */ n_pts = rpois(lambda1); /* simulate location of the first */ first = random_int(0, m); if(first > n_pts) n_ichi = 0; else n_ichi = n_pts/(m+1) + (int)(first < (n_pts % (m+1))); /* simulate no. chiamata from the no-interference model */ n_nichi = rpois(lambda2); if(!obligate_chiasma || n_ichi + n_nichi > 0) break; } /* simulate no. chiasmta + intermediate points */ /* first check if we have space */ if(n_pts > max_pts) { ptloc = (double *)S_realloc((char *)ptloc, n_pts*2, max_pts, sizeof(double)); max_pts = n_pts*2; } for(j=0; j<n_pts; j++) ptloc[j] = runif(0.0, L); /* sort them */ R_rsort(ptloc, n_pts); /* take every (m+1)st */ for(j=first, k=0; j<n_pts; j += (m+1), k++) ptloc[k] = ptloc[j]; n_ichi = k; /* simulate chiasmata from no-interference model */ for(j=0; j<n_nichi; j++) ptloc[n_ichi + j] = runif(0.0, L); /* sort the combined ones */ R_rsort(ptloc, n_ichi + n_nichi); /* thin by 1/2 */ nxo[i] = 0; for(j=0; j<n_ichi + n_nichi; j++) { if(unif_rand() < 0.5) { Loc[i][nxo[i]] = ptloc[j]; (nxo[i])++; } } } /* loop over no. simulations */ } /* m > 0 */ PutRNGstate(); }