Beispiel #1
0
static SEXP ArraySubset(SEXP x, SEXP s, SEXP call, int drop)
{
    int k, mode;
    SEXP dimnames, dimnamesnames, p, q, r, result, xdims;
    const void *vmaxsave = vmaxget();

    mode = TYPEOF(x);
    xdims = getAttrib(x, R_DimSymbol);
    k = length(xdims);

    /* k is now the number of dims */
    int **subs = (int**)R_alloc(k, sizeof(int*));
    int *indx = (int*)R_alloc(k, sizeof(int));
    int *bound = (int*)R_alloc(k, sizeof(int));
    R_xlen_t *offset = (R_xlen_t*)R_alloc(k, sizeof(R_xlen_t));

    /* Construct a vector to contain the returned values. */
    /* Store its extents. */

    R_xlen_t n = 1;
    r = s;
    for (int i = 0; i < k; i++) {
	SETCAR(r, int_arraySubscript(i, CAR(r), xdims, x, call));
	bound[i] = LENGTH(CAR(r));
	n *= bound[i];
	r = CDR(r);
    }
    PROTECT(result = allocVector(mode, n));
    r = s;
    for (int i = 0; i < k; i++) {
	indx[i] = 0;
	subs[i] = INTEGER(CAR(r));
	r = CDR(r);
    }
    offset[0] = 1;
    for (int i = 1; i < k; i++)
	offset[i] = offset[i - 1] * INTEGER(xdims)[i - 1];

    /* Transfer the subset elements from "x" to "a". */

    for (R_xlen_t i = 0; i < n; i++) {
	R_xlen_t ii = 0;
	for (int j = 0; j < k; j++) {
	    int jj = subs[j][indx[j]];
	    if (jj == NA_INTEGER) {
		ii = NA_INTEGER;
		goto assignLoop;
	    }
	    if (jj < 1 || jj > INTEGER(xdims)[j])
		errorcall(call, R_MSG_subs_o_b);
	    ii += (jj - 1) * offset[j];
	}

      assignLoop:
	switch (mode) {
	case LGLSXP:
	    if (ii != NA_INTEGER)
		LOGICAL(result)[i] = LOGICAL(x)[ii];
	    else
		LOGICAL(result)[i] = NA_LOGICAL;
	    break;
	case INTSXP:
	    if (ii != NA_INTEGER)
		INTEGER(result)[i] = INTEGER(x)[ii];
	    else
		INTEGER(result)[i] = NA_INTEGER;
	    break;
	case REALSXP:
	    if (ii != NA_INTEGER)
		REAL(result)[i] = REAL(x)[ii];
	    else
		REAL(result)[i] = NA_REAL;
	    break;
	case CPLXSXP:
	    if (ii != NA_INTEGER) {
		COMPLEX(result)[i] = COMPLEX(x)[ii];
	    }
	    else {
		COMPLEX(result)[i].r = NA_REAL;
		COMPLEX(result)[i].i = NA_REAL;
	    }
	    break;
	case STRSXP:
	    if (ii != NA_INTEGER)
		SET_STRING_ELT(result, i, STRING_ELT(x, ii));
	    else
		SET_STRING_ELT(result, i, NA_STRING);
	    break;
	case VECSXP:
	    if (ii != NA_INTEGER)
		SET_VECTOR_ELT(result, i, VECTOR_ELT_FIX_NAMED(x, ii));
	    else
		SET_VECTOR_ELT(result, i, R_NilValue);
	    break;
	case RAWSXP:
	    if (ii != NA_INTEGER)
		RAW(result)[i] = RAW(x)[ii];
	    else
		RAW(result)[i] = (Rbyte) 0;
	    break;
	default:
	    errorcall(call, _("array subscripting not handled for this type"));
	    break;
	}
	if (n > 1) {
	    int j = 0;
	    while (++indx[j] >= bound[j]) {
		indx[j] = 0;
		j = (j + 1) % k;
	    }
	}
    }

    PROTECT(xdims = allocVector(INTSXP, k));
    for(int i = 0 ; i < k ; i++)
	INTEGER(xdims)[i] = bound[i];
    setAttrib(result, R_DimSymbol, xdims);
    UNPROTECT(1); /* xdims */

    /* The array elements have been transferred. */
    /* Now we need to transfer the attributes. */
    /* Most importantly, we need to subset the */
    /* dimnames of the returned value. */

    dimnames = getAttrib(x, R_DimNamesSymbol);
    PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
    if (dimnames != R_NilValue) {
	int j = 0;
	PROTECT(xdims = allocVector(VECSXP, k));
	if (TYPEOF(dimnames) == VECSXP) {
	    r = s;
	    for (int i = 0; i < k ; i++) {
		if (bound[i] > 0) {
		  SET_VECTOR_ELT(xdims, j++,
			ExtractSubset(VECTOR_ELT(dimnames, i),
				      allocVector(STRSXP, bound[i]),
				      CAR(r), call));
		} else { /* 0-length dims have NULL dimnames */
		    SET_VECTOR_ELT(xdims, j++, R_NilValue);
		}
		r = CDR(r);
	    }
	}
	else {
	    p = dimnames;
	    q = xdims;
	    r = s;
	    for(int i = 0 ; i < k; i++) {
		SETCAR(q, allocVector(STRSXP, bound[i]));
		SETCAR(q, ExtractSubset(CAR(p), CAR(q), CAR(r), call));
		p = CDR(p);
		q = CDR(q);
		r = CDR(r);
	    }
	}
	setAttrib(xdims, R_NamesSymbol, dimnamesnames);
	setAttrib(result, R_DimNamesSymbol, xdims);
	UNPROTECT(1); /* xdims */
    }
    /* This was removed for matrices in 1998
       copyMostAttrib(x, result); */
    /* Free temporary memory */
    vmaxset(vmaxsave);
    if (drop)
	DropDims(result);
    UNPROTECT(2); /* dimnamesnames, result */
    return result;
}
Beispiel #2
0
/* This is for all cases with a single index, including 1D arrays and
   matrix indexing of arrays */
static SEXP VectorSubset(SEXP x, SEXP s, SEXP call)
{
    R_xlen_t n;
    int mode;
    R_xlen_t stretch = 1;
    SEXP indx, result, attrib, nattrib;

    if (s == R_MissingArg) return duplicate(x);

    PROTECT(s);
    attrib = getAttrib(x, R_DimSymbol);

    /* Check to see if we have special matrix subscripting. */
    /* If we do, make a real subscript vector and protect it. */

    if (isMatrix(s) && isArray(x) && ncols(s) == length(attrib)) {
        if (isString(s)) {
            s = strmat2intmat(s, GetArrayDimnames(x), call);
            UNPROTECT(1);
            PROTECT(s);
        }
        if (isInteger(s) || isReal(s)) {
            s = mat2indsub(attrib, s, call);
            UNPROTECT(1);
            PROTECT(s);
        }
    }

    /* Convert to a vector of integer subscripts */
    /* in the range 1:length(x). */

    PROTECT(indx = makeSubscript(x, s, &stretch, call));
    n = XLENGTH(indx);

    /* Allocate the result. */

    mode = TYPEOF(x);
    /* No protection needed as ExtractSubset does not allocate */
    result = allocVector(mode, n);
    if (mode == VECSXP || mode == EXPRSXP)
	/* we do not duplicate the values when extracting the subset,
	   so to be conservative mark the result as NAMED = 2 */
	SET_NAMED(result, 2);

    PROTECT(result = ExtractSubset(x, result, indx, call));
    if (result != R_NilValue) {
	if (
	    ((attrib = getAttrib(x, R_NamesSymbol)) != R_NilValue) ||
	    ( /* here we might have an array.  Use row names if 1D */
		isArray(x) && LENGTH(getAttrib(x, R_DimNamesSymbol)) == 1 &&
		(attrib = getAttrib(x, R_DimNamesSymbol)) != R_NilValue &&
		(attrib = GetRowNames(attrib)) != R_NilValue
		)
	    ) {
	    PROTECT(attrib);
	    nattrib = allocVector(TYPEOF(attrib), n);
	    PROTECT(nattrib); /* seems unneeded */
	    nattrib = ExtractSubset(attrib, nattrib, indx, call);
	    setAttrib(result, R_NamesSymbol, nattrib);
	    UNPROTECT(2); /* attrib, nattrib */
	}
	if ((attrib = getAttrib(x, R_SrcrefSymbol)) != R_NilValue &&
	    TYPEOF(attrib) == VECSXP) {
	    nattrib = allocVector(VECSXP, n);
	    PROTECT(nattrib); /* seems unneeded */
	    nattrib = ExtractSubset(attrib, nattrib, indx, call);
	    setAttrib(result, R_SrcrefSymbol, nattrib);
	    UNPROTECT(1);
	}
	/* FIXME:  this is wrong, because the slots are gone, so result is an invalid object of the S4 class! JMC 3/3/09 */
#ifdef _S4_subsettable
	if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
	    setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
	    SET_S4_OBJECT(result);
	}
#endif
    }
    UNPROTECT(3);
    return result;
}
Beispiel #3
0
static SEXP MatrixSubset(SEXP x, SEXP s, SEXP call, int drop)
{
    SEXP attr, result, sr, sc, dim;
    int nr, nc, nrs, ncs;
    R_xlen_t i, j, ii, jj, ij, iijj;

    nr = nrows(x);
    nc = ncols(x);

    /* Note that "s" is protected on entry. */
    /* The following ensures that pointers remain protected. */
    dim = getAttrib(x, R_DimSymbol);

    sr = SETCAR(s, int_arraySubscript(0, CAR(s), dim, x, call));
    sc = SETCADR(s, int_arraySubscript(1, CADR(s), dim, x, call));
    nrs = LENGTH(sr);
    ncs = LENGTH(sc);
    /* Check this does not overflow: currently only possible on 32-bit */
    if ((double)nrs * (double)ncs > R_XLEN_T_MAX)
	error(_("dimensions would exceed maximum size of array"));
    PROTECT(sr);
    PROTECT(sc);
    result = allocVector(TYPEOF(x), (R_xlen_t) nrs * (R_xlen_t) ncs);
    PROTECT(result);
    for (i = 0; i < nrs; i++) {
	ii = INTEGER(sr)[i];
	if (ii != NA_INTEGER) {
	    if (ii < 1 || ii > nr)
		errorcall(call, R_MSG_subs_o_b);
	    ii--;
	}
	for (j = 0; j < ncs; j++) {
	    jj = INTEGER(sc)[j];
	    if (jj != NA_INTEGER) {
		if (jj < 1 || jj > nc)
		    errorcall(call, R_MSG_subs_o_b);
		jj--;
	    }
	    ij = i + j * nrs;
	    if (ii == NA_INTEGER || jj == NA_INTEGER) {
		switch (TYPEOF(x)) {
		case LGLSXP:
		case INTSXP:
		    INTEGER(result)[ij] = NA_INTEGER;
		    break;
		case REALSXP:
		    REAL(result)[ij] = NA_REAL;
		    break;
		case CPLXSXP:
		    COMPLEX(result)[ij].r = NA_REAL;
		    COMPLEX(result)[ij].i = NA_REAL;
		    break;
		case STRSXP:
		    SET_STRING_ELT(result, ij, NA_STRING);
		    break;
		case VECSXP:
		    SET_VECTOR_ELT(result, ij, R_NilValue);
		    break;
		case RAWSXP:
		    RAW(result)[ij] = (Rbyte) 0;
		    break;
		default:
		    errorcall(call, _("matrix subscripting not handled for this type"));
		    break;
		}
	    }
	    else {
		iijj = ii + jj * nr;
		switch (TYPEOF(x)) {
		case LGLSXP:
		    LOGICAL(result)[ij] = LOGICAL(x)[iijj];
		    break;
		case INTSXP:
		    INTEGER(result)[ij] = INTEGER(x)[iijj];
		    break;
		case REALSXP:
		    REAL(result)[ij] = REAL(x)[iijj];
		    break;
		case CPLXSXP:
		    COMPLEX(result)[ij] = COMPLEX(x)[iijj];
		    break;
		case STRSXP:
		    SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
		    break;
		case VECSXP:
		    SET_VECTOR_ELT(result, ij, VECTOR_ELT_FIX_NAMED(x, iijj));
		    break;
		case RAWSXP:
		    RAW(result)[ij] = RAW(x)[iijj];
		    break;
		default:
		    errorcall(call, _("matrix subscripting not handled for this type"));
		    break;
		}
	    }
	}
    }
    if(nrs >= 0 && ncs >= 0) {
	PROTECT(attr = allocVector(INTSXP, 2));
	INTEGER(attr)[0] = nrs;
	INTEGER(attr)[1] = ncs;
	setAttrib(result, R_DimSymbol, attr);
	UNPROTECT(1);
    }

    /* The matrix elements have been transferred.  Now we need to */
    /* transfer the attributes.	 Most importantly, we need to subset */
    /* the dimnames of the returned value. */

    if (nrs >= 0 && ncs >= 0) {
	SEXP dimnames, dimnamesnames, newdimnames;
	dimnames = getAttrib(x, R_DimNamesSymbol);
	PROTECT(dimnamesnames = getAttrib(dimnames, R_NamesSymbol));
	if (!isNull(dimnames)) {
	    PROTECT(newdimnames = allocVector(VECSXP, 2));
	    if (TYPEOF(dimnames) == VECSXP) {
	      SET_VECTOR_ELT(newdimnames, 0,
		    ExtractSubset(VECTOR_ELT(dimnames, 0),
				  allocVector(STRSXP, nrs), sr, call));
	      SET_VECTOR_ELT(newdimnames, 1,
		    ExtractSubset(VECTOR_ELT(dimnames, 1),
				  allocVector(STRSXP, ncs), sc, call));
	    }
	    else {
	      SET_VECTOR_ELT(newdimnames, 0,
		    ExtractSubset(CAR(dimnames),
				  allocVector(STRSXP, nrs), sr, call));
	      SET_VECTOR_ELT(newdimnames, 1,
		    ExtractSubset(CADR(dimnames),
				  allocVector(STRSXP, ncs), sc, call));
	    }
	    setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
	    setAttrib(result, R_DimNamesSymbol, newdimnames);
	    UNPROTECT(1); /* newdimnames */
	}
	UNPROTECT(1); /* dimnamesnames */
    }
    /*  Probably should not do this:
    copyMostAttrib(x, result); */
    if (drop)
	DropDims(result);
    UNPROTECT(3);
    return result;
}
Beispiel #4
0
SEXP _do_subset_xts (SEXP x, SEXP sr, SEXP sc, SEXP drop) {
  SEXP result;
  int i, j, nr, nc, nrs, ncs;
  int P=0;

  SEXP Dim = getAttrib(x, R_DimSymbol);
  nrs = nrows(x);ncs = ncols(x);
  nr = length(sr); nc = length(sc);

  SEXP oindex, nindex;
  oindex = getAttrib(x, install("index"));
  PROTECT(nindex = allocVector(TYPEOF(oindex), nr)); P++;
  PROTECT(result = allocVector(TYPEOF(x), nr*nc)); P++;
  j = 0;

  double *real_nindex=NULL, *real_oindex, *real_result=NULL, *real_x=NULL; 
  int *int_nindex=NULL, *int_oindex, *int_result=NULL, *int_x=NULL; 
  int *int_sr=NULL, *int_sc=NULL;
  int_sr = INTEGER(sr);
  int_sc = INTEGER(sc);

  copyAttributes(x, result);

  if(TYPEOF(x)==LGLSXP) {
    int_x = LOGICAL(x); 
    int_result = LOGICAL(result); 
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);
    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  /* branch into INTSXP and REALSXP, as these are most
     common/important types for time series data 
  */
  if(TYPEOF(x)==INTSXP) {
    int_x = INTEGER(x); 
    int_result = INTEGER(result); 
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    /* loop through remaining columns */
    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          int_result[i+j*nr] = NA_INTEGER;
        else
          int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  if(TYPEOF(x)==REALSXP) {
    real_x = REAL(x);
    real_result = REAL(result);
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          real_result[i+j*nr] = NA_REAL;
        else
          real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          real_result[i+j*nr] = NA_REAL;
        else
          real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          real_result[i+j*nr] = NA_REAL;
        else
          real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  if(TYPEOF(x)==CPLXSXP) {
    /*
    real_x = REAL(x);
    real_result = REAL(result);
    */
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER) {
          COMPLEX(result)[i+j*nr].r = NA_REAL;
          COMPLEX(result)[i+j*nr].i = NA_REAL;
        } else
          COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER) {
          COMPLEX(result)[i+j*nr].r = NA_REAL;
          COMPLEX(result)[i+j*nr].i = NA_REAL;
        } else
          COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER) {
          COMPLEX(result)[i+j*nr].r = NA_REAL;
          COMPLEX(result)[i+j*nr].i = NA_REAL;
        } else
          COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  } else
  if(TYPEOF(x)==STRSXP) {
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          SET_STRING_ELT(result, i+j*nr, NA_STRING);
        else
          SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          SET_STRING_ELT(result, i+j*nr, NA_STRING);
        else
          SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          SET_STRING_ELT(result, i+j*nr, NA_STRING);
        else
          SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs)));
      }
    }
  } else
  if(TYPEOF(x)==RAWSXP) {
    /*
    real_x = REAL(x);
    real_result = REAL(result);
    */
    if(TYPEOF(nindex)==INTSXP) {
      int_nindex = INTEGER(nindex);
      int_oindex = INTEGER(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        int_nindex[i] = int_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          RAW(result)[i+j*nr] = 0;
        else
          RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    } else
    if(TYPEOF(nindex)==REALSXP) {
      real_nindex = REAL(nindex);
      real_oindex = REAL(oindex);
      for(i=0; i<nr; i++) {
        if(int_sr[i] == NA_INTEGER)
          error("'i' contains NA");
        if(int_sr[i] > nrs || int_sc[j] > ncs)
          error("'i' or 'j' out of range");
        real_nindex[i] = real_oindex[int_sr[i]-1];
        if(int_sc[j] == NA_INTEGER)
          RAW(result)[i+j*nr] = 0;
        else
          RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
    copyAttributes(oindex, nindex);
    setAttrib(result, install("index"), nindex);

    for(j=1; j<nc; j++) {
      for(i=0; i<nr; i++) {
        if(int_sc[j] == NA_INTEGER)
          RAW(result)[i+j*nr] = 0;
        else
          RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)];
      }
    }
  }


  if(!isNull(Dim) && nr >= 0 && nc >= 0) {
  SEXP dim;
  PROTECT(dim = allocVector(INTSXP,2));P++;
  INTEGER(dim)[0] = nr;
  INTEGER(dim)[1] = nc;
  setAttrib(result, R_DimSymbol, dim);

   if (nr >= 0 && nc >= 0) {
    SEXP dimnames, dimnamesnames, newdimnames;
    dimnames = getAttrib(x, R_DimNamesSymbol);
    dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
    if (!isNull(dimnames)) {
        PROTECT(newdimnames = allocVector(VECSXP, 2));
        if (TYPEOF(dimnames) == VECSXP) {
          SET_VECTOR_ELT(newdimnames, 0,
            ExtractSubset(VECTOR_ELT(dimnames, 0),
                  allocVector(STRSXP, nr), sr));
          SET_VECTOR_ELT(newdimnames, 1,
            ExtractSubset(VECTOR_ELT(dimnames, 1),
                  allocVector(STRSXP, nc), sc));
        }
        else {
          SET_VECTOR_ELT(newdimnames, 0,
            ExtractSubset(CAR(dimnames),
                  allocVector(STRSXP, nr), sr));
          SET_VECTOR_ELT(newdimnames, 1,
            ExtractSubset(CADR(dimnames),
                  allocVector(STRSXP, nc), sc));
        }
        setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
        setAttrib(result, R_DimNamesSymbol, newdimnames);
        UNPROTECT(1);
    }
    }

  }
  setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
  if(nc == 1 && LOGICAL(drop)[0])
    setAttrib(result, R_DimSymbol, R_NilValue);


  UNPROTECT(P);
  return result;
}