/* R function qsort(x, index.return) */ SEXP attribute_hidden do_qsort(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP x, sx; int indx_ret, n; double *vx = NULL; int *ivx = NULL; Rboolean x_real, x_int; checkArity(op, args); x = CAR(args); if (!isNumeric(x)) error(_("argument is not a numeric vector")); x_real= TYPEOF(x) == REALSXP; x_int = !x_real && (TYPEOF(x) == INTSXP || TYPEOF(x) == LGLSXP); PROTECT(sx = (x_real || x_int) ? duplicate(x) : coerceVector(x, REALSXP)); SET_ATTRIB(sx, R_NilValue); SET_OBJECT(sx, 0); /* if x has names, drop them, since they won't be ordered if (!isNull(getAttrib(sx, R_NamesSymbol))) setAttrib(sx, R_NamesSymbol, R_NilValue); */ indx_ret = asLogical(CADR(args)); n = LENGTH(x); if(x_int) ivx = INTEGER(sx); else vx = REAL(sx); if(indx_ret) { SEXP ans, ansnames, indx; int i, *ix; /* answer will have x = sorted x , ix = index :*/ PROTECT(ans = allocVector(VECSXP, 2)); PROTECT(ansnames = allocVector(STRSXP, 2)); PROTECT(indx = allocVector(INTSXP, n)); ix = INTEGER(indx); for(i = 0; i < n; i++) ix[i] = i+1; if(x_int) R_qsort_int_I(ivx, ix, 1, n); else R_qsort_I(vx, ix, 1, n); SET_VECTOR_ELT(ans, 0, sx); SET_VECTOR_ELT(ans, 1, indx); SET_STRING_ELT(ansnames, 0, mkChar("x")); SET_STRING_ELT(ansnames, 1, mkChar("ix")); setAttrib(ans, R_NamesSymbol, ansnames); UNPROTECT(4); return ans; } else { if(x_int) R_qsort_int(ivx, 1, n); else R_qsort(vx, 1, n); UNPROTECT(1); return sx; } }
double sn0(double *x, int n, int is_sorted, double *a2) { /* Efficient algorithm for the scale estimator: S*_n = LOMED_{i} HIMED_{i} |x_i - x_j| which can equivalently be written as S*_n = LOMED_{i} LOMED_{j != i} |x_i - x_j| Arguments : x : double array (length >= n) containing the observations n : number of observations (n>=2) is_sorted: logical indicating if x is already sorted a2 : to contain a2[i] := LOMED_{j != i} | x_i - x_j |, for i=1,...,n */ /* Local variables */ double medA, medB; int i, diff, half, Amin, Amax, even, length; int leftA,leftB, nA,nB, tryA,tryB, rightA,rightB; int n1_2; if(!is_sorted) R_qsort(x, 1, n); a2[0] = x[n / 2] - x[0]; n1_2 = (n + 1) / 2; /* first half for() loop : */ for (i = 2; i <= n1_2; ++i) { nA = i - 1; nB = n - i; diff = nB - nA; leftA = leftB = 1; rightA = rightB = nB; Amin = diff / 2 + 1; Amax = diff / 2 + nA; while (leftA < rightA) { length = rightA - leftA + 1; even = 1 - length % 2; half = (length - 1) / 2; tryA = leftA + half; tryB = leftB + half; if (tryA < Amin) { rightB = tryB; leftA = tryA + even; } else { if (tryA > Amax) { rightA = tryA; leftB = tryB + even; } else { medA = x[i - 1] - x[i - tryA + Amin - 2]; medB = x[tryB + i - 1] - x[i - 1]; if (medA >= medB) { rightA = tryA; leftB = tryB + even; } else { rightB = tryB; leftA = tryA + even; } } } } /* while */ if (leftA > Amax) { a2[i - 1] = x[leftB + i - 1] - x[i - 1]; } else { medA = x[i - 1] - x[i - leftA + Amin - 2]; medB = x[leftB + i - 1] - x[i - 1]; a2[i - 1] = fmin2(medA,medB); } } /* second half for() loop : */ for (i = n1_2 + 1; i <= n - 1; ++i) { nA = n - i; nB = i - 1; diff = nB - nA; leftA = leftB = 1; rightA = rightB = nB; Amin = diff / 2 + 1; Amax = diff / 2 + nA; while (leftA < rightA) { length = rightA - leftA + 1; even = 1 - length % 2; half = (length - 1) / 2; tryA = leftA + half; tryB = leftB + half; if (tryA < Amin) { rightB = tryB; leftA = tryA + even; } else { if (tryA > Amax) { rightA = tryA; leftB = tryB + even; } else { medA = x[i + tryA - Amin] - x[i - 1]; medB = x[i - 1] - x[i - tryB - 1]; if (medA >= medB) { rightA = tryA; leftB = tryB + even; } else { rightB = tryB; leftA = tryA + even; } } } } /* while */ if (leftA > Amax) { a2[i - 1] = x[i - 1] - x[i - leftB - 1]; } else { medA = x[i + leftA - Amin] - x[i - 1]; medB = x[i - 1] - x[i - leftB - 1]; a2[i - 1] = fmin2(medA,medB); } } a2[n - 1] = x[n - 1] - x[n1_2 - 1]; return pull(a2, n, n1_2); } /* sn0 */
double qn0(double *x, int n) { /*-------------------------------------------------------------------- Efficient algorithm for the scale estimator: Q*_n = { |x_i - x_j|; i<j }_(k) [= Qn without scaling ] i.e. the k-th order statistic of the |x_i - x_j| Parameters of the function Qn : x : double array containing the observations n : number of observations (n >=2) */ double *y = (double *)R_alloc(n, sizeof(double)); double *work = (double *)R_alloc(n, sizeof(double)); double *a_srt = (double *)R_alloc(n, sizeof(double)); double *a_cand = (double *)R_alloc(n, sizeof(double)); int *left = (int *)R_alloc(n, sizeof(int)); int *right = (int *)R_alloc(n, sizeof(int)); int *p = (int *)R_alloc(n, sizeof(int)); int *q = (int *)R_alloc(n, sizeof(int)); int *weight = (int *)R_alloc(n, sizeof(int)); double trial = R_NaReal;/* -Wall */ Rboolean found; int h, i, j,jj,jh; /* Following should be `long long int' : they can be of order n^2 */ int64_t k, knew, nl,nr, sump,sumq; h = n / 2 + 1; k = (int64_t)h * (h - 1) / 2; for (i = 0; i < n; ++i) { y[i] = x[i]; left [i] = n - i + 1; right[i] = (i <= h) ? n : n - (i - h); /* the n - (i-h) is from the paper; original code had `n' */ } R_qsort(y, 1, n); /* y := sort(x) */ nl = (int64_t)n * (n + 1) / 2; nr = (int64_t)n * n; knew = k + nl;/* = k + (n+1 \over 2) */ found = FALSE; #ifdef DEBUG_qn REprintf("qn0(): h,k= %2d,%2d; nl,nr= %d,%d\n", h,k, nl,nr); #endif /* L200: */ while(!found && nr - nl > n) { j = 0; /* Truncation to float : try to make sure that the same values are got later (guard bits !) */ for (i = 1; i < n; ++i) { if (left[i] <= right[i]) { weight[j] = right[i] - left[i] + 1; jh = left[i] + weight[j] / 2; work[j] = (float)(y[i] - y[n - jh]); ++j; } } trial = whimed_i(work, weight, j, a_cand, a_srt, /*iw_cand*/ p); #ifdef DEBUG_qn REprintf(" ..!found: whimed("); # ifdef DEBUG_long REprintf("wrk=c("); for(i=0; i < j; i++) REprintf("%s%g", (i>0)? ", " : "", work[i]); REprintf("),\n wgt=c("); for(i=0; i < j; i++) REprintf("%s%d", (i>0)? ", " : "", weight[i]); REprintf("), j= %3d) -> trial= %7g\n", j, trial); # else REprintf("j=%3d) -> trial= %g:", j, trial); # endif #endif j = 0; for (i = n - 1; i >= 0; --i) { while (j < n && ((float)(y[i] - y[n - j - 1])) < trial) ++j; p[i] = j; } #ifdef DEBUG_qn REprintf(" f_1: j=%2d", j); #endif j = n + 1; for (i = 0; i < n; ++i) { while ((float)(y[i] - y[n - j + 1]) > trial) --j; q[i] = j; } sump = 0; sumq = 0; for (i = 0; i < n; ++i) { sump += p[i]; sumq += q[i] - 1; } #ifdef DEBUG_qn REprintf(" f_2 -> j=%2d, sump|q= %lld,%lld", j, sump,sumq); #endif if (knew <= sump) { for (i = 0; i < n; ++i) right[i] = p[i]; nr = sump; #ifdef DEBUG_qn REprintf("knew <= sump =: nr , new right[]\n"); #endif } else if (knew > sumq) { for (i = 0; i < n; ++i) left[i] = q[i]; nl = sumq; #ifdef DEBUG_qn REprintf("knew > sumq =: nl , new left[]\n"); #endif } else { /* sump < knew <= sumq */ found = TRUE; #ifdef DEBUG_qn REprintf("sump < knew <= sumq ---> FOUND\n"); #endif } } /* while */ if (found) return trial; else { #ifdef DEBUG_qn REprintf(".. not fnd -> new work[]"); #endif j = 0; for (i = 1; i < n; ++i) { for (jj = left[i]; jj <= right[i]; ++jj) { work[j] = y[i] - y[n - jj]; j++; }/* j will be = sum_{i=2}^n (right[i] - left[i] + 1)_{+} */ } #ifdef DEBUG_qn REprintf(" of length %d; knew-nl=%d\n", j, knew-nl); #endif /* return pull(work, j - 1, knew - nl) : */ knew -= (nl + 1); /* -1: 0-indexing */ rPsort(work, j, knew); return(work[knew]); } } /* qn0 */
/* R function qsort(x, index.return) */ SEXP attribute_hidden do_qsort(SEXP call, SEXP op, SEXP args, SEXP rho) { SEXP x, sx; int indx_ret; double *vx = NULL; int *ivx = NULL; Rboolean x_real, x_int; checkArity(op, args); x = CAR(args); if (!isNumeric(x)) error(_("argument is not a numeric vector")); x_real= TYPEOF(x) == REALSXP; x_int = !x_real && (TYPEOF(x) == INTSXP || TYPEOF(x) == LGLSXP); PROTECT(sx = (x_real || x_int) ? duplicate(x) : coerceVector(x, REALSXP)); SET_ATTRIB(sx, R_NilValue); SET_OBJECT(sx, 0); indx_ret = asLogical(CADR(args)); R_xlen_t n = XLENGTH(x); #ifdef LONG_VECTOR_SUPPORT Rboolean isLong = n > INT_MAX; #endif if(x_int) ivx = INTEGER(sx); else vx = REAL(sx); if(indx_ret) { SEXP ans, ansnames, indx; /* answer will have x = sorted x , ix = index :*/ PROTECT(ans = allocVector(VECSXP, 2)); PROTECT(ansnames = allocVector(STRSXP, 2)); #ifdef LONG_VECTOR_SUPPORT if (isLong) { PROTECT(indx = allocVector(REALSXP, n)); double *ix = REAL(indx); for(R_xlen_t i = 0; i < n; i++) ix[i] = (double) (i+1); if(x_int) R_qsort_int_R(ivx, ix, 1, n); else R_qsort_R(vx, ix, 1, n); } else #endif { PROTECT(indx = allocVector(INTSXP, n)); int *ix = INTEGER(indx); int nn = (int) n; for(int i = 0; i < nn; i++) ix[i] = i+1; if(x_int) R_qsort_int_I(ivx, ix, 1, nn); else R_qsort_I(vx, ix, 1, nn); } SET_VECTOR_ELT(ans, 0, sx); SET_VECTOR_ELT(ans, 1, indx); SET_STRING_ELT(ansnames, 0, mkChar("x")); SET_STRING_ELT(ansnames, 1, mkChar("ix")); setAttrib(ans, R_NamesSymbol, ansnames); UNPROTECT(4); return ans; } else { if(x_int) R_qsort_int(ivx, 1, n); else R_qsort(vx, 1, n); UNPROTECT(1); return sx; } }
void F77_SUB(qsort3)(double *v, int *ii, int *jj) { R_qsort(v, *ii, *jj); }
/* Written by Mikko Korpela */ void gini(double *x_const, int *n_ptr, double *result){ int i; double *x; long double sum1, sum2, this_x; listnode *tmp1, *tmp2; int n = *n_ptr; if(n<2){ *result = 0; return; } /* Sort the numbers */ x = (double *) R_alloc(n, sizeof(double)); for(i=0;i<n;i++) x[i] = x_const[i]; R_qsort(x, 1, n); /* Setup for grow_exp */ tmp1 = (listnode *) R_alloc(1, sizeof(listnode)); tmp1->next = NULL; tmp1->data = (long double)x[0]; tmp1->valid = 1; /* Cumulative sum */ for(i=1;i<n;i++){ grow_exp(tmp1, (long double)x[i]); tmp2 = tmp1; sum1 = 0; while(tmp2 && tmp2->valid){ sum1 += tmp2->data; tmp2 = tmp2->next; } x[i] = (double)sum1; } /* Setup for grow_exp */ if(tmp1->next) tmp1->next->valid = 0; tmp2 = (listnode *) R_alloc(1, sizeof(listnode)); tmp2->next = NULL; /* Gini */ tmp1->data = (long double)x[n-1] * (n-1); tmp2->data = (long double)x[0]; tmp2->valid = 1; grow_exp(tmp2, (long double)x[0]); for(i=1;i<n-1;i++){ this_x = (long double)x[i]; grow_exp(tmp1, this_x * i); grow_exp(tmp2, this_x * (i+2)); } sum1 = 0; while(tmp1 && tmp1->valid){ sum1 += tmp1->data; tmp1 = tmp1->next; } sum2 = 0; while(tmp2 && tmp2->valid){ sum2 += tmp2->data; tmp2 = tmp2->next; } *result = (double)((sum1-sum2)/((long double)x[n-1]*n)); }