//[[Rcpp::export]] std::vector<double> biexponential_transform(std::vector<double> input,double A,double B,double C,double D,double F,double W,double tol,int maxIt) { struct biexponential_info params; int i; int fail=0; double step; params.a = A; params.b = B; params.c = C; params.d = D; params.f = F; params.w = W; unsigned nLen = input.size(); for(i=0;i<nLen;i++) { int j; double Tol = tol; int MaxIt = maxIt; params.y = input.at(i); for(j=0,step=0.5; biexponential_fn(-step,(void*)¶ms)*biexponential_fn(step,(void*)¶ms) >0;step*=1.5,j+=1){ if(j > MaxIt){ break; } } input.at(i) = R_zeroin(-step,step,biexponential_fn,(void*)¶ms,&Tol,&MaxIt); if(MaxIt==-1){ fail=fail+1; } } if(fail>0) Rcpp::warning("%d values of %d have not converged.",fail,nLen); return input; }
//[[Rcpp::export]] std::vector<double> biexponential_transform(std::vector<double> input, double A, double B, double C, double D, double F, double W, double tol, int maxIt) { struct biexponential_info params; params.a = A; params.b = B; params.c = C; params.d = D; params.f = F; params.w = W; void* pParams = (void*)¶ms; int fail = 0; for(int i=0; i < input.size(); i++) { params.y = input.at(i); double step = 0.5; for(int j=0; j<maxIt; j++, step*=1.5) { double bi1 = biexponential_fn(step, pParams); double bi2 = biexponential_fn(-step, pParams); if (bi1 * bi2 > 0) { break; } } double tol_ = tol; int maxIt_ = maxIt; input.at(i) = R_zeroin(-step, step, biexponential_fn, pParams, &tol_, &maxIt_); if(MaxIt==-1){ fail=fail+1; } } if(fail>0) Rcpp::warning("%d values have not converged.", fail); return input; }
/* zeroin(f, xmin, xmax, tol, maxiter) */ SEXP do_zeroin(SEXP call, SEXP op, SEXP args, SEXP rho) { double xmin, xmax, tol; int iter; SEXP v, res; struct callinfo info; checkArity(op, args); PrintDefaults(rho); /* the function to be minimized */ v = CAR(args); if (!isFunction(v)) errorcall(call, _("attempt to minimize non-function")); args = CDR(args); /* xmin */ xmin = asReal(CAR(args)); if (!R_FINITE(xmin)) errorcall(call, _("invalid 'xmin' value")); args = CDR(args); /* xmax */ xmax = asReal(CAR(args)); if (!R_FINITE(xmax)) errorcall(call, _("invalid 'xmax' value")); if (xmin >= xmax) errorcall(call, _("'xmin' not less than 'xmax'")); args = CDR(args); /* tol */ tol = asReal(CAR(args)); if (!R_FINITE(tol) || tol <= 0.0) errorcall(call, _("invalid 'tol' value")); args = CDR(args); /* maxiter */ iter = asInteger(CAR(args)); if (iter <= 0) errorcall(call, _("'maxiter' must be positive")); info.R_env = rho; PROTECT(info.R_fcall = lang2(v, R_NilValue)); /* the info used in fcn2() */ SETCADR(info.R_fcall, allocVector(REALSXP, 1)); PROTECT(res = allocVector(REALSXP, 3)); REAL(res)[0] = R_zeroin(xmin, xmax, (double (*)(double, void*)) fcn2, (void *) &info, &tol, &iter); REAL(res)[1] = (double)iter; REAL(res)[2] = tol; UNPROTECT(2); return res; }
/* * use R built-in root finder API :R_zeroin */ double Logicle::solve (double b, double w) { // w == 0 means its really arcsinh if (w == 0) return b; // precision is the same as that of b double tolerance = 2 * b * EPSILON; struct sfun_info params; params.b=b; params.w=w; // bracket the root double d_lo = 0; double d_hi = b; int MaxIt = 20; double d ; d= R_zeroin(d_lo,d_hi,logicle_fn,(void*)¶ms,&tolerance,&MaxIt); return d; }