SEXP attribute_hidden do_subset_dflt(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, ax, px, x, subs;
int drop, i, nsubs, type;
/* By default we drop extents of length 1 */
/* Handle cases of extracting a single element from a simple vector
or matrix directly to improve speed for these simple cases. */
SEXP cdrArgs = CDR(args);
SEXP cddrArgs = CDR(cdrArgs);
if (cdrArgs != R_NilValue && cddrArgs == R_NilValue &&
TAG(cdrArgs) == R_NilValue) {
/* one index, not named */
SEXP x = CAR(args);
if (ATTRIB(x) == R_NilValue) {
SEXP s = CAR(cdrArgs);
R_xlen_t i = scalarIndex(s);
switch (TYPEOF(x)) {
case REALSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarReal( REAL(x)[i-1] );
break;
case INTSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarInteger( INTEGER(x)[i-1] );
break;
case LGLSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarLogical( LOGICAL(x)[i-1] );
break;
// do the more rare cases as well, since we've already prepared everything:
case CPLXSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarComplex( COMPLEX(x)[i-1] );
break;
case RAWSXP:
if (i >= 1 && i <= XLENGTH(x))
return ScalarRaw( RAW(x)[i-1] );
break;
default: break;
}
}
}
else if (cddrArgs != R_NilValue && CDR(cddrArgs) == R_NilValue &&
TAG(cdrArgs) == R_NilValue && TAG(cddrArgs) == R_NilValue) {
/* two indices, not named */
SEXP x = CAR(args);
SEXP attr = ATTRIB(x);
if (TAG(attr) == R_DimSymbol && CDR(attr) == R_NilValue) {
/* only attribute of x is 'dim' */
SEXP dim = CAR(attr);
if (TYPEOF(dim) == INTSXP && LENGTH(dim) == 2) {
/* x is a matrix */
SEXP si = CAR(cdrArgs);
SEXP sj = CAR(cddrArgs);
R_xlen_t i = scalarIndex(si);
R_xlen_t j = scalarIndex(sj);
int nrow = INTEGER(dim)[0];
int ncol = INTEGER(dim)[1];
if (i > 0 && j > 0 && i <= nrow && j <= ncol) {
/* indices are legal scalars */
R_xlen_t k = i - 1 + nrow * (j - 1);
switch (TYPEOF(x)) {
case REALSXP:
if (k < LENGTH(x))
return ScalarReal( REAL(x)[k] );
break;
case INTSXP:
if (k < LENGTH(x))
return ScalarInteger( INTEGER(x)[k] );
break;
case LGLSXP:
if (k < LENGTH(x))
return ScalarLogical( LOGICAL(x)[k] );
break;
case CPLXSXP:
if (k < LENGTH(x))
return ScalarComplex( COMPLEX(x)[k] );
break;
case RAWSXP:
if (k < LENGTH(x))
return ScalarRaw( RAW(x)[k] );
break;
default: break;
}
}
}
}
}
PROTECT(args);
drop = 1;
ExtractDropArg(args, &drop);
x = CAR(args);
/* This was intended for compatibility with S, */
/* but in fact S does not do this. */
/* FIXME: replace the test by isNull ... ? */
if (x == R_NilValue) {
UNPROTECT(1);
return x;
}
subs = CDR(args);
nsubs = length(subs); /* Will be short */
type = TYPEOF(x);
/* Here coerce pair-based objects into generic vectors. */
/* All subsetting takes place on the generic vector form. */
ax = x;
if (isVector(x))
PROTECT(ax);
else if (isPairList(x)) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
if (ndim > 1) {
PROTECT(ax = allocArray(VECSXP, dim));
setAttrib(ax, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_DimNamesSymbol));
}
else {
PROTECT(ax = allocVector(VECSXP, length(x)));
setAttrib(ax, R_NamesSymbol, getAttrib(x, R_NamesSymbol));
}
for(px = x, i = 0 ; px != R_NilValue ; px = CDR(px))
SET_VECTOR_ELT(ax, i++, CAR(px));
}
else errorcall(call, R_MSG_ob_nonsub, type2char(TYPEOF(x)));
/* This is the actual subsetting code. */
/* The separation of arrays and matrices is purely an optimization. */
if(nsubs < 2) {
SEXP dim = getAttrib(x, R_DimSymbol);
int ndim = length(dim);
PROTECT(ans = VectorSubset(ax, (nsubs == 1 ? CAR(subs) : R_MissingArg),
call));
/* one-dimensional arrays went through here, and they should
have their dimensions dropped only if the result has
length one and drop == TRUE
*/
if(ndim == 1) {
SEXP attr, attrib, nattrib;
int len = length(ans);
if(!drop || len > 1) {
// must grab these before the dim is set.
SEXP nm = PROTECT(getAttrib(ans, R_NamesSymbol));
PROTECT(attr = allocVector(INTSXP, 1));
INTEGER(attr)[0] = length(ans);
setAttrib(ans, R_DimSymbol, attr);
if((attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue) {
/* reinstate dimnames, include names of dimnames */
PROTECT(nattrib = duplicate(attrib));
SET_VECTOR_ELT(nattrib, 0, nm);
setAttrib(ans, R_DimNamesSymbol, nattrib);
setAttrib(ans, R_NamesSymbol, R_NilValue);
UNPROTECT(1);
}
UNPROTECT(2);
}
}
} else {
if (nsubs != length(getAttrib(x, R_DimSymbol)))
errorcall(call, _("incorrect number of dimensions"));
if (nsubs == 2)
ans = MatrixSubset(ax, subs, call, drop);
else
ans = ArraySubset(ax, subs, call, drop);
PROTECT(ans);
}
/* Note: we do not coerce back to pair-based lists. */
/* They are "defunct" in this version of R. */
if (type == LANGSXP) {
ax = ans;
PROTECT(ans = allocList(LENGTH(ax)));
if ( LENGTH(ax) > 0 )
SET_TYPEOF(ans, LANGSXP);
for(px = ans, i = 0 ; px != R_NilValue ; px = CDR(px))
SETCAR(px, VECTOR_ELT(ax, i++));
setAttrib(ans, R_DimSymbol, getAttrib(ax, R_DimSymbol));
setAttrib(ans, R_DimNamesSymbol, getAttrib(ax, R_DimNamesSymbol));
setAttrib(ans, R_NamesSymbol, getAttrib(ax, R_NamesSymbol));
SET_NAMED(ans, NAMED(ax)); /* PR#7924 */
}
else {
PROTECT(ans);
}
if (ATTRIB(ans) != R_NilValue) { /* remove probably erroneous attr's */
setAttrib(ans, R_TspSymbol, R_NilValue);
#ifdef _S4_subsettable
if(!IS_S4_OBJECT(x))
#endif
setAttrib(ans, R_ClassSymbol, R_NilValue);
}
UNPROTECT(4);
return ans;
}
// Here's the main interpolate function, using
// Least Squares AutoRegression (LSAR):
void InterpolateAudio(float *buffer, int len,
int firstBad, int numBad)
{
int N = len;
int i, row, col;
wxASSERT(len > 0 &&
firstBad >= 0 &&
numBad < len &&
firstBad+numBad <= len);
if(numBad >= len)
return; //should never have been called!
if (firstBad == 0) {
// The algorithm below has a weird asymmetry in that it
// performs poorly when interpolating to the left. If
// we're asked to interpolate the left side of a buffer,
// we just reverse the problem and try it that way.
float *buffer2 = new float[len];
for(i=0; i<len; i++)
buffer2[len-1-i] = buffer[i];
InterpolateAudio(buffer2, len, len-numBad, numBad);
for(i=0; i<len; i++)
buffer[len-1-i] = buffer2[i];
return;
}
Vector s(len, buffer);
// Choose P, the order of the autoregression equation
int P = imin(numBad * 3, 50);
P = imin(P, imax(firstBad - 1, len - (firstBad + numBad) - 1));
if (P < 3) {
LinearInterpolateAudio(buffer, len, firstBad, numBad);
return;
}
// Add a tiny amount of random noise to the input signal -
// this sounds like a bad idea, but the amount we're adding
// is only about 1 bit in 16-bit audio, and it's an extremely
// effective way to avoid nearly-singular matrices. If users
// run it more than once they get slightly different results;
// this is sometimes even advantageous.
for(i=0; i<N; i++)
s[i] += (rand()-(RAND_MAX/2))/(RAND_MAX*10000.0);
// Solve for the best autoregression coefficients
// using a least-squares fit to all of the non-bad
// data we have in the buffer
Matrix X(P, P);
Vector b(P);
for(i=0; i<len-P; i++)
if (i+P < firstBad || i >= (firstBad + numBad))
for(row=0; row<P; row++) {
for(col=0; col<P; col++)
X[row][col] += (s[i+row] * s[i+col]);
b[row] += s[i+P] * s[i+row];
}
Matrix Xinv(P, P);
if (!InvertMatrix(X, Xinv)) {
// The matrix is singular! Fall back on linear...
// In practice I have never seen this happen if
// we add the tiny bit of random noise.
LinearInterpolateAudio(buffer, len, firstBad, numBad);
return;
}
// This vector now contains the autoregression coefficients
Vector a = Xinv * b;
// Create a matrix (a "Toeplitz" matrix, as it turns out)
// which encodes the autoregressive relationship between
// elements of the sequence.
Matrix A(N-P, N);
for(row=0; row<N-P; row++) {
for(col=0; col<P; col++)
A[row][row+col] = -a[col];
A[row][row+P] = 1;
}
// Split both the Toeplitz matrix and the signal into
// two pieces. Note that this code could be made to
// work even in the case where the "bad" samples are
// not contiguous, but currently it assumes they are.
// "u" is for unknown (bad)
// "k" is for known (good)
Matrix Au = MatrixSubset(A, 0, N-P, firstBad, numBad);
Matrix A_left = MatrixSubset(A, 0, N-P, 0, firstBad);
Matrix A_right = MatrixSubset(A, 0, N-P,
firstBad+numBad, N-(firstBad+numBad));
Matrix Ak = MatrixConcatenateCols(A_left, A_right);
Vector s_left = VectorSubset(s, 0, firstBad);
Vector s_right = VectorSubset(s, firstBad+numBad,
N-(firstBad+numBad));
Vector sk = VectorConcatenate(s_left, s_right);
// Do some linear algebra to find the best possible
// values that fill in the "bad" area
Matrix AuT = TransposeMatrix(Au);
Matrix X1 = MatrixMultiply(AuT, Au);
Matrix X2(X1.Rows(), X1.Cols());
if (!InvertMatrix(X1, X2)) {
// The matrix is singular! Fall back on linear...
LinearInterpolateAudio(buffer, len, firstBad, numBad);
return;
}
Matrix X2b = X2 * -1.0;
Matrix X3 = MatrixMultiply(X2b, AuT);
Matrix X4 = MatrixMultiply(X3, Ak);
// This vector contains our best guess as to the
// unknown values
Vector su = X4 * sk;
// Put the results into the return buffer
for(i=0; i<numBad; i++)
buffer[firstBad+i] = (float)su[i];
}