/**********************************************************************
* 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();
}
