bool test_gradients_directly(Shapeset *ss) { _F_ printf("V. direct check of the gradient values\n"); maxdif = 0.; bool passed = true; int index, *indices, ii; for (int iv = 0; iv < 8; iv++) { index = ss->get_vertex_index(iv); printf("."); fflush(stdout); if (!test(ss, index)) passed = false; } order1_t eorder = H3D_MAX_ELEMENT_ORDER; for (int ie = 0; ie < 12; ie++) { for (int ori = 0; ori < 2; ori++) { indices = ss->get_edge_indices(ie, ori, eorder); for (ii = 0; ii < ss->get_num_edge_fns(eorder); ii++) { printf("."); fflush(stdout); if (!test(ss, indices[ii])) passed = false; } } } order2_t forder(H3D_MAX_ELEMENT_ORDER, H3D_MAX_ELEMENT_ORDER); for (int ic = 0; ic < 6; ic++) { for (int ori = 0; ori < 8; ori++) { indices = ss->get_face_indices(ic, ori, forder); for (ii = 0; ii < ss->get_num_face_fns(forder); ii++) { printf("."); fflush(stdout); if (!test(ss, indices[ii])) passed = false; } } } order3_t order(H3D_MAX_ELEMENT_ORDER, H3D_MAX_ELEMENT_ORDER, H3D_MAX_ELEMENT_ORDER); indices = ss->get_bubble_indices(order); for (ii = 0; ii < ss->get_num_bubble_fns(order); ii++) { printf("."); fflush(stdout); if (!test(ss, indices[ii])) passed = false; } printf("\n"); printf("maximal difference is %g, which is %g * h^2\n", maxdif, maxdif / hh / hh); return passed; }
SEXP bmerge(SEXP iArg, SEXP xArg, SEXP icolsArg, SEXP xcolsArg, SEXP isorted, SEXP rollarg, SEXP rollendsArg, SEXP nomatch, SEXP retFirstArg, SEXP retLengthArg, SEXP allLen1Arg) { int xN, iN, protecti=0; roll = 0.0; nearest = FALSE; enc_warn = TRUE; if (isString(rollarg)) { if (strcmp(CHAR(STRING_ELT(rollarg,0)),"nearest") != 0) error("roll is character but not 'nearest'"); roll=1.0; nearest=TRUE; // the 1.0 here is just any non-0.0, so roll!=0.0 can be used later } else { if (!isReal(rollarg)) error("Internal error: roll is not character or double"); roll = REAL(rollarg)[0]; // more common case (rolling forwards or backwards) or no roll when 0.0 } rollabs = fabs(roll); i = iArg; x = xArg; // set globals so bmerge_r can see them. if (!isInteger(icolsArg)) error("Internal error: icols is not integer vector"); if (!isInteger(xcolsArg)) error("Internal error: xcols is not integer vector"); if (LENGTH(icolsArg) > LENGTH(xcolsArg)) error("Internal error: length(icols) [%d] > length(xcols) [%d]", LENGTH(icolsArg), LENGTH(xcolsArg)); icols = INTEGER(icolsArg); xcols = INTEGER(xcolsArg); xN = LENGTH(VECTOR_ELT(x,0)); iN = LENGTH(VECTOR_ELT(i,0)); ncol = LENGTH(icolsArg); // there may be more sorted columns in x than involved in the join for(int col=0; col<ncol; col++) { if (icols[col]==NA_INTEGER) error("Internal error. icols[%d] is NA", col); if (xcols[col]==NA_INTEGER) error("Internal error. xcols[%d] is NA", col); if (icols[col]>LENGTH(i) || icols[col]<1) error("icols[%d]=%d outside range [1,length(i)=%d]", col, icols[col], LENGTH(i)); if (xcols[col]>LENGTH(x) || xcols[col]<1) error("xcols[%d]=%d outside range [1,length(x)=%d]", col, xcols[col], LENGTH(x)); int it = TYPEOF(VECTOR_ELT(i, icols[col]-1)); int xt = TYPEOF(VECTOR_ELT(x, xcols[col]-1)); if (it != xt) error("typeof x.%s (%s) != typeof i.%s (%s)", CHAR(STRING_ELT(getAttrib(x,R_NamesSymbol),xcols[col]-1)), type2char(xt), CHAR(STRING_ELT(getAttrib(i,R_NamesSymbol),icols[col]-1)), type2char(it)); } if (!isInteger(retFirstArg) || LENGTH(retFirstArg)!=iN) error("retFirst must be integer vector the same length as nrow(i)"); retFirst = INTEGER(retFirstArg); if (!isInteger(retLengthArg) || LENGTH(retLengthArg)!=iN) error("retLength must be integer vector the same length as nrow(i)"); retLength = INTEGER(retLengthArg); if (!isLogical(allLen1Arg) || LENGTH(allLen1Arg) != 1) error("allLen1 must be a length 1 logical vector"); allLen1 = LOGICAL(allLen1Arg); if (!isLogical(rollendsArg) || LENGTH(rollendsArg) != 2) error("rollends must be a length 2 logical vector"); rollends = LOGICAL(rollendsArg); if (nearest && TYPEOF(VECTOR_ELT(i, icols[ncol-1]-1))==STRSXP) error("roll='nearest' can't be applied to a character column, yet."); for (int j=0; j<iN; j++) { // defaults need to populated here as bmerge_r may well not touch many locations, say if the last row of i is before the first row of x. retFirst[j] = INTEGER(nomatch)[0]; // default to no match for NA goto below // retLength[j] = 0; // TO DO: do this to save the branch below and later branches at R level to set .N to 0 retLength[j] = INTEGER(nomatch)[0]==0 ? 0 : 1; } allLen1[0] = TRUE; // All-0 and All-NA are considered all length 1 according to R code currently. Really, it means any(length>1). o = NULL; if (!LOGICAL(isorted)[0]) { SEXP order = PROTECT(vec_init(length(icolsArg), ScalarInteger(1))); // rep(1, length(icolsArg)) SEXP oSxp = PROTECT(forder(i, icolsArg, ScalarLogical(FALSE), ScalarLogical(TRUE), order, ScalarLogical(FALSE))); protecti += 2; if (!LENGTH(oSxp)) o = NULL; else o = INTEGER(oSxp); } if (iN) bmerge_r(-1,xN,-1,iN,0,1,1); UNPROTECT(protecti); return(R_NilValue); }