SEXP CatBoostCreateFromFile_R(SEXP poolFileParam,
SEXP cdFileParam,
SEXP pairsFileParam,
SEXP delimiterParam,
SEXP hasHeaderParam,
SEXP threadCountParam,
SEXP verboseParam) {
SEXP result = NULL;
R_API_BEGIN();
TPoolPtr poolPtr = std::make_unique<TPool>();
ReadPool(CHAR(asChar(cdFileParam)),
CHAR(asChar(poolFileParam)),
CHAR(asChar(pairsFileParam)),
asInteger(threadCountParam),
asLogical(verboseParam),
CHAR(asChar(delimiterParam))[0],
asLogical(hasHeaderParam),
TVector<TString>(),
poolPtr.get());
result = PROTECT(R_MakeExternalPtr(poolPtr.get(), R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(result, _Finalizer<TPoolHandle>, TRUE);
poolPtr.release();
R_API_END();
UNPROTECT(1);
return result;
}
/* throw away line if it
* - is empty
* - exactly starts with comment char '%'
*/
SEXP c_dt_preproc(SEXP s_path_in, SEXP s_path_out, SEXP s_data_sect_index) {
FILE* handle_in;
FILE* handle_out;
const char* path_in = CHAR(asChar(s_path_in));
const char* path_out = CHAR(asChar(s_path_out));
int data_sect_index = asInteger(s_data_sect_index);
/* FIXME: check in convert that we do not overflow (2 c files)*/
char line_buf_1[100000];
char line_buf_2[100000];
char* line_p;
int data_sect_reached = 0;
handle_in = fopen(path_in, "r");
path_out = CHAR(asChar(s_path_out));
handle_out = fopen(path_out, "w");
/* FIXME: can we skip these lines faster? *1/ */
for (int i = 0; i<data_sect_index; i++) {
fgets(line_buf_1, sizeof line_buf_1, handle_in);
}
while (fgets(line_buf_1, sizeof line_buf_1, handle_in)) {
dt_convert_line(line_buf_1, line_buf_2);
if (!is_empty(line_buf_2)) {
fputs(line_buf_2, handle_out);
}
}
fclose(handle_in);
fclose(handle_out);
return R_NilValue;
}
SEXP
scene_addText(SEXP scene, SEXP x, SEXP y, SEXP labels, SEXP html)
{
QGraphicsScene* s = unwrapQObject(scene, QGraphicsScene);
int nlab = length(labels);
int i, n = length(x);
for (i = 0; i < n; i++) {
QGraphicsTextItem *ti = s->addText(QString());
ti->setFont(QFont("Arial"));
if (LOGICAL(html)[0]) {
ti->setHtml(QString::fromLocal8Bit(CHAR(asChar(STRING_ELT(labels, i % nlab)))));
ti->setOpenExternalLinks(true);
ti->setToolTip("I am HTML!");
}
else {
ti->setPlainText(QString::fromLocal8Bit(CHAR(asChar(STRING_ELT(labels, i % nlab)))));
}
ti->setPos(REAL(x)[i], REAL(y)[i]);
ti->setFlags(QGraphicsItem::ItemIsMovable |
QGraphicsItem::ItemIsSelectable |
QGraphicsItem::ItemIsFocusable |
QGraphicsItem::ItemIgnoresTransformations);
}
return R_NilValue;
}
SEXP BWGSectionList_add(SEXP r_sections, SEXP r_seq, SEXP r_ranges,
SEXP r_score, SEXP r_format)
{
struct bwgSection *sections = NULL;
const char *seq = CHAR(asChar(r_seq));
double *score = REAL(r_score);
const char *format = CHAR(asChar(r_format));
SEXP ans;
struct lm *lm;
enum bwgSectionType type = bwgTypeBedGraph;
if (sameString(format, "fixedStep"))
type = bwgTypeFixedStep;
else if (sameString(format, "variableStep"))
type = bwgTypeVariableStep;
if (r_sections != R_NilValue) {
sections = R_ExternalPtrAddr(r_sections);
lm = R_ExternalPtrAddr(R_ExternalPtrTag(r_sections));
} else lm = lmInit(0);
pushRHandlers();
if (r_ranges != R_NilValue) {
BWGSectionList_addRle(§ions, seq, r_ranges, score, type, lm);
} else {
BWGSectionList_addAtomic(§ions, seq, score, length(r_score), lm);
}
popRHandlers();
PROTECT(ans = R_MakeExternalPtr(sections, R_NilValue, R_NilValue));
R_SetExternalPtrTag(ans, R_MakeExternalPtr(lm, R_NilValue, R_NilValue));
UNPROTECT(1);
return ans;
}
/* --- .Call ENTRY POINT --- */
SEXP BWGFile_summary(SEXP r_filename, SEXP r_chrom, SEXP r_ranges,
SEXP r_size, SEXP r_type, SEXP r_default_value)
{
pushRHandlers();
struct bbiFile * file = bigWigFileOpen((char *)CHAR(asChar(r_filename)));
enum bbiSummaryType type =
bbiSummaryTypeFromString((char *)CHAR(asChar(r_type)));
double default_value = asReal(r_default_value);
int *start = INTEGER(get_IRanges_start(r_ranges));
int *width = INTEGER(get_IRanges_width(r_ranges));
SEXP ans;
PROTECT(ans = allocVector(VECSXP, length(r_chrom)));
for (int i = 0; i < length(r_chrom); i++) {
int size = INTEGER(r_size)[i];
char *chrom = (char *)CHAR(STRING_ELT(r_chrom, i));
SEXP r_values = allocVector(REALSXP, size);
double *values = REAL(r_values);
for (int j = 0; j < size; j++)
values[j] = default_value;
SET_VECTOR_ELT(ans, i, r_values);
bool success = bigWigSummaryArray(file, chrom, start[i] - 1,
start[i] - 1 + width[i], type, size,
values);
if (!success)
warning("Failed to summarize range %d (%s:%d-%d)", i, chrom, start[i],
start[i] - 1 + width[i]);
}
bbiFileClose(&file);
popRHandlers();
UNPROTECT(1);
return ans;
}
void STGM::CBoolSphereSystem::simSphereSys(R_Calldata d)
{
GetRNGstate();
if(isNull(d->call)) {
/* get arguments */
double p1=REAL_ARG_LIST(d->args,0),p2=0;
const char *fname = CHAR(STRING_ELT(d->fname,0));
/* ACHTUNG: 'const' function braucht 2 Argumente */
if(std::strcmp(fname, "const" ))
p2=REAL_ARG_LIST(d->args,1);
// set spheroid label
const char *label = translateChar(asChar(d->label));
if(!std::strcmp(fname, "rlnorm")) {
simSpheresPerfect(p1,p2,label,d->isPerfect);
} else {
R_rndGen_t<rdist2_t> rrandom(p1,p2,fname);
/* simulate with R's random generating functions */
simSpheres<R_rndGen_t<rdist2_t> >(rrandom,label);
}
} else {
/* eval R call for user defined radii distribution */
const char *label = translateChar(asChar(d->label));
R_eval_t<double> reval(d->call, d->rho);
simSpheres<R_eval_t<double> &>(reval,label);
}
PutRNGstate();
}
SEXP R_mongo_collection_rename(SEXP ptr_col, SEXP db, SEXP name) {
mongoc_collection_t *col = r2col(ptr_col);
bson_error_t err;
const char *new_db = NULL;
if(db != R_NilValue)
new_db = translateCharUTF8(asChar(db));
if(!mongoc_collection_rename(col, new_db, translateCharUTF8(asChar(name)), false, &err))
stop(err.message);
return ScalarLogical(1);
}
SEXP Csparse_MatrixMarket(SEXP x, SEXP fname)
{
FILE *f = fopen(CHAR(asChar(fname)), "w");
if (!f)
error(_("failure to open file \"%s\" for writing"),
CHAR(asChar(fname)));
if (!cholmod_l_write_sparse(f, AS_CHM_SP(x),
(CHM_SP)NULL, (char*) NULL, &c))
error(_("cholmod_l_write_sparse returned error code"));
fclose(f);
return R_NilValue;
}
SEXP BWGFile_fromWIG(SEXP r_infile, SEXP r_seqlengths, SEXP r_outfile) {
pushRHandlers();
struct lm *lm = lmInit(0);
struct hash *lenHash = createIntHash(r_seqlengths);
struct bwgSection *sections =
bwgParseWig((char *)CHAR(asChar(r_infile)), FALSE, lenHash, itemsPerSlot,
lm);
bwgCreate(sections, lenHash, blockSize, itemsPerSlot, TRUE, TRUE, TRUE,
(char *)CHAR(asChar(r_outfile)));
lmCleanup(&lm);
freeHash(&lenHash);
popRHandlers();
return r_outfile;
}
SEXP Tsparse_to_Csparse(SEXP x, SEXP tri)
{
cholmod_triplet *chxt = as_cholmod_triplet(x);
cholmod_sparse *chxs = cholmod_triplet_to_sparse(chxt, chxt->nnz, &c);
int uploT = 0; char *diag = "";
Free(chxt);
if (asLogical(tri)) { /* triangular sparse matrices */
uploT = (strcmp(CHAR(asChar(GET_SLOT(x, Matrix_uploSym))), "U")) ?
-1 : 1;
diag = CHAR(asChar(GET_SLOT(x, Matrix_diagSym)));
}
return chm_sparse_to_SEXP(chxs, 1, uploT, diag,
duplicate(GET_SLOT(x, Matrix_DimNamesSym)));
}
Cholesky_rd::Cholesky_rd(SEXP x, int nn) {
if (!(IS_S4_OBJECT(x)))
error(_("S4 object expected but not provided"));
// FIXME: This check should be changed to an S4 "is" check, which
// should be available in Rinternals.h but isn't.
if (strcmp(CHAR(asChar(getAttrib(x, R_ClassSymbol))),
"Cholesky") != 0)
error(_("Object must be of class \"Cholesky\""));
uplo = CHAR(asChar(GET_SLOT(x, install("uplo"))));
int *dims = INTEGER(GET_SLOT(x, lme4_DimSym));
n = nn;
if (dims[0] != n || dims[1] != n)
error(_("Cholesky object must be a square matrix of size %d"));
X = REAL(GET_SLOT(x, lme4_xSym));
}
QByteArray
MethodCall::argKey(SEXP arg) const
{
const char * className = CHAR(asChar(getAttrib(arg, R_ClassSymbol)));
const char *r = "";
if (arg == R_NilValue)
r = "u";
else if (TYPEOF(arg) == INTSXP) {
if (inherits(arg, "QtEnum"))
r = className;
else r = "i";
} else if (TYPEOF(arg) == REALSXP)
r = "n";
else if (TYPEOF(arg) == STRSXP)
r = "s";
else if(TYPEOF(arg) == LGLSXP)
r = "B";
else if (TYPEOF(arg) == EXTPTRSXP) {
SmokeObject *o = SmokeObject::fromSexp(arg);
if (o == 0 || o->smoke() == 0) {
r = "a";
} else {
r = o->smoke()->classes[o->classId()].className;
}
} else {
r = "U";
}
return QByteArray(r);
}
STGM::Spheres convert_C_Spheres(SEXP R_spheres) {
SEXP R_tmp, R_ctr;
int id=0,
N=length(R_spheres);
STGM::Spheres spheres;
spheres.reserve(N);
double r=0;
int interior=1;
const char *label = "N";
for(int i=0; i<N; i++) {
PROTECT(R_tmp = VECTOR_ELT(R_spheres,i));
PROTECT(R_ctr = AS_NUMERIC( getListElement( R_tmp, "center")));
id = asInteger (AS_INTEGER( getListElement( R_tmp, "id")));
r = asReal(getListElement( R_tmp, "r"));
if(!isNull(getAttrib(R_tmp, install("label"))))
label = translateChar(asChar(getAttrib(R_tmp, install("label"))));
if(!isNull(getAttrib(R_tmp, install("interior"))))
interior = asLogical(getAttrib(R_tmp, install("interior")));
spheres.push_back(STGM::CSphere(REAL(R_ctr)[0],REAL(R_ctr)[1],REAL(R_ctr)[2],r,id,label,interior));
UNPROTECT(2);
}
return spheres;
}
SEXP CatBoostPrepareEval_R(SEXP approxParam, SEXP typeParam, SEXP columnCountParam, SEXP threadCountParam) {
SEXP result = NULL;
R_API_BEGIN();
SEXP dataDim = getAttrib(approxParam, R_DimSymbol);
size_t dataRows = static_cast<size_t>(INTEGER(dataDim)[0]) / asInteger(columnCountParam);
TVector<TVector<double>> prediction(asInteger(columnCountParam), TVector<double>(dataRows));
for (size_t i = 0, k = 0; i < dataRows; ++i) {
for (size_t j = 0; j < prediction.size(); ++j) {
prediction[j][i] = static_cast<double>(REAL(approxParam)[k++]);
}
}
NPar::TLocalExecutor executor;
executor.RunAdditionalThreads(asInteger(threadCountParam) - 1);
EPredictionType predictionType;
CB_ENSURE(TryFromString<EPredictionType>(CHAR(asChar(typeParam)), predictionType),
"unsupported prediction type: 'Probability', 'Class' or 'RawFormulaVal' was expected");
prediction = PrepareEval(predictionType, prediction, &executor);
size_t predictionSize = prediction.size() * dataRows;
result = PROTECT(allocVector(REALSXP, predictionSize));
for (size_t i = 0, k = 0; i < dataRows; ++i) {
for (size_t j = 0; j < prediction.size(); ++j) {
REAL(result)[k++] = prediction[j][i];
}
}
R_API_END();
UNPROTECT(1);
return result;
}
SEXP CatBoostPredictMulti_R(SEXP modelParam, SEXP poolParam, SEXP verboseParam,
SEXP typeParam, SEXP treeCountStartParam, SEXP treeCountEndParam, SEXP threadCountParam) {
SEXP result = NULL;
R_API_BEGIN();
TFullModelHandle model = reinterpret_cast<TFullModelHandle>(R_ExternalPtrAddr(modelParam));
TPoolHandle pool = reinterpret_cast<TPoolHandle>(R_ExternalPtrAddr(poolParam));
EPredictionType predictionType;
CB_ENSURE(TryFromString<EPredictionType>(CHAR(asChar(typeParam)), predictionType),
"unsupported prediction type: 'Probability', 'Class' or 'RawFormulaVal' was expected");
TVector<TVector<double>> prediction = ApplyModelMulti(*model,
*pool,
asLogical(verboseParam),
predictionType,
asInteger(treeCountStartParam),
asInteger(treeCountEndParam),
asInteger(threadCountParam));
size_t predictionSize = prediction.size() * pool->Docs.GetDocCount();
result = PROTECT(allocVector(REALSXP, predictionSize));
for (size_t i = 0, k = 0; i < pool->Docs.GetDocCount(); ++i) {
for (size_t j = 0; j < prediction.size(); ++j) {
REAL(result)[k++] = prediction[j][i];
}
}
R_API_END();
UNPROTECT(1);
return result;
}
SEXP CatBoostOutputModel_R(SEXP modelParam, SEXP fileParam) {
R_API_BEGIN();
TFullModelHandle model = reinterpret_cast<TFullModelHandle>(R_ExternalPtrAddr(modelParam));
OutputModel(*model, CHAR(asChar(fileParam)));
R_API_END();
return ScalarLogical(1);
}
SEXP
do_read_SPSS(SEXP file)
{
const char *filename = CHAR(PROTECT(asChar(file)));
FILE *fp = fopen(R_ExpandFileName(filename), "rb");
char buf[5];
SEXP ans;
if(!fp)
error(_("unable to open file: '%s'"), strerror(errno));
if(fread_pfm(buf, sizeof(char), 4, fp) != 4) {
fclose(fp);
error(_("problem in reading file '%s'"), filename);
}
buf[4] = '\0';
if (0 == strncmp("$FL2", buf, 4)) {
fclose(fp);
ans = read_SPSS_SAVE(filename);
} else {
if (!is_PORT(fp)) {
fclose(fp);
error(_("file '%s' is not in any supported SPSS format"),
filename);
}
fclose(fp);
ans = read_SPSS_PORT(filename);
}
UNPROTECT(1);
return ans;
}
bool VirtualValue::operator==(const VirtualValue& that) const
{
if ( mKind == that.mKind )
{
switch ( mKind )
{
case eEmpty:
return true;
case eNumber:
return asNumber() == that.asNumber();
case eReal:
return asReal() == that.asReal();
case eChar:
return asChar() == that.asChar();
case eBool:
return asBoolean() == that.asBoolean();
case eString:
return asString() == that.asString();
case eObject:
return &asObject() == &that.asObject();
case eArray:
return &asArray() == &that.asArray();
}
}
return false;
}
static NJson::TJsonValue LoadFitParams(SEXP fitParamsAsJson) {
TString paramsStr(CHAR(asChar(fitParamsAsJson)));
TStringInput is(paramsStr);
NJson::TJsonValue result;
NJson::ReadJsonTree(&is, &result);
return result;
}
SEXP get_minc_separations(SEXP filename) {
int result;
mihandle_t hvol;
const char *filepath = CHAR(asChar(filename));
midimhandle_t dimensions[3];
double* voxel_separations = malloc(3 * sizeof(double));
SEXP output = PROTECT(allocVector(REALSXP, 3));
result = miopen_volume(filepath,
MI2_OPEN_READ, &hvol);
if (result != MI_NOERROR) {
miclose_volume(hvol);
error("Error opening input file: %s.\n", filepath);
}
result =
miget_volume_dimensions(hvol, MI_DIMCLASS_SPATIAL, MI_DIMATTR_ALL,
MI_DIMORDER_FILE, 3, dimensions);
result =
miget_dimension_separations(dimensions, MI_ORDER_FILE,
3, voxel_separations);
miclose_volume(hvol);
for(int i = 0; i < 3; ++i) REAL(output)[i] = voxel_separations[i];
UNPROTECT(1);
return(output);
}
/**
Convert R object into either a function or the address of a C routine.
For a C routine, the caller can specify the name of the typedef which is
checked using the TAG for the external pointer.
*/
void *
Rfrom_Callbable(SEXP obj, const char * const TypeDefName, CallableType *type)
{
/* If TypeDefName is NULL, we don't bother checking*/
if(TYPEOF(obj) == EXTPTRSXP) {
if(TypeDefName && R_ExternalPtrTag(obj) != Rf_install(TypeDefName)) {
PROBLEM "[RfromCallbable] incorrect type name for a native routine pointer %s, not %s",
CHAR(asChar(R_ExternalPtrTag(obj))), TypeDefName
ERROR;
}
if(type)
*type = NATIVE_ROUTINE;
return(R_ExternalPtrAddr(obj));
} else if(TYPEOF(obj) == CLOSXP) {
if(type)
*type = R_FUNCTION;
return(obj);
}
PROBLEM "the Rfrom_Callable routine only handles native routines and "
ERROR;
return((void *) NULL);
}
//----------------------------------------------------------------------------
SEXP dbnGenerateEvidences(SEXP net, SEXP numSlices)
{
SEXP res;
int flag = -1;
PROTECT(net = AS_INTEGER(net));
int NetNum = INTEGER_VALUE(net);
PROTECT(numSlices = AS_CHARACTER(numSlices));
char * arg1 = CHAR(asChar(numSlices));
try
{
pDBNs[NetNum]->GenerateEvidences(arg1);
}
catch (pnl::CException &E)
{
ErrorString = E.GetMessage();
flag = 1;
}
catch(...)
{
ErrorString = "Unrecognized exception during execution of GenerateEvidences function";
flag = 1;
}
PROTECT(res = NEW_INTEGER(1));
int * pres = INTEGER_POINTER(res);
pres[0] = flag;
UNPROTECT(3);
return (res);
}
SEXP R_digest(SEXP x, SEXP algo){
if(!isString(x))
error("Argument 'x' must be a character vector.");
if(!isString(algo))
error("Argument 'algo' must be a character vector.");
int len = length(x);
SEXP out = PROTECT(allocVector(STRSXP, len));
for (int i = 0; i < len; i++) {
/* check for NA */
if(STRING_ELT(x, i) == NA_STRING) {
SET_STRING_ELT(out, i, NA_STRING);
continue;
}
/* create hash */
const char* str = CHAR(STRING_ELT(x, i));
unsigned char md_value[EVP_MAX_MD_SIZE];
unsigned int md_len = digest_string(str, CHAR(asChar(algo)), strlen(str), md_value);
/* create character vector */
char mdString[2*md_len+1];
for (int i = 0; i < md_len; i++) {
sprintf(&mdString[i*2], "%02x", (unsigned int) md_value[i]);
}
mdString[2*md_len] = '\0';
SET_STRING_ELT(out, i, mkChar(mdString));
}
UNPROTECT(1);
return out;
}
SEXP rsqlite_query_send(SEXP handle, SEXP statement, SEXP bind_data) {
SQLiteConnection* con = rsqlite_connection_from_handle(handle);
sqlite3* db_connection = con->drvConnection;
sqlite3_stmt* db_statement = NULL;
int state, bind_count;
int rows = 0, cols = 0;
if (con->resultSet) {
if (con->resultSet->completed != 1)
warning("Closing result set with pending rows");
rsqlite_result_free(con);
}
rsqlite_result_alloc(con);
SQLiteResult* res = con->resultSet;
/* allocate and init a new result set */
res->completed = 0;
char* dyn_statement = RS_DBI_copyString(CHAR(asChar(statement)));
res->statement = dyn_statement;
res->drvResultSet = db_statement;
state = sqlite3_prepare_v2(db_connection, dyn_statement, -1,
&db_statement, NULL);
if (state != SQLITE_OK) {
exec_error(con, "error in statement");
}
if (db_statement == NULL) {
exec_error(con, "nothing to execute");
}
res->drvResultSet = (void*) db_statement;
bind_count = sqlite3_bind_parameter_count(db_statement);
if (bind_count > 0 && bind_data != R_NilValue) {
rows = GET_LENGTH(GET_ROWNAMES(bind_data));
cols = GET_LENGTH(bind_data);
}
res->isSelect = sqlite3_column_count(db_statement) > 0;
res->rowCount = 0; /* fake's cursor's row count */
res->rowsAffected = -1; /* no rows affected */
rsqlite_exception_set(con, state, "OK");
if (res->isSelect) {
if (bind_count > 0) {
select_prepared_query(db_statement, bind_data, bind_count, rows, con);
}
} else {
if (bind_count > 0) {
non_select_prepared_query(db_statement, bind_data, bind_count, rows, con);
} else {
state = sqlite3_step(db_statement);
if (state != SQLITE_DONE) {
exec_error(con, "rsqlite_query_send: could not execute1");
}
}
res->completed = 1;
res->rowsAffected = sqlite3_changes(db_connection);
}
return handle;
}
SEXP magma_dgeMatrix_norm(SEXP obj, SEXP type)
{
#ifdef HIPLAR_WITH_MAGMA
return ScalarReal(magma_get_norm(obj, CHAR(asChar(type))));
#endif
return R_NilValue;
}
SEXP R_mongo_collection_new(SEXP ptr_client, SEXP collection, SEXP db) {
mongoc_client_t *client = r2client(ptr_client);
mongoc_collection_t *col = mongoc_client_get_collection (client, translateCharUTF8(asChar(db)), translateCharUTF8(asChar(collection)));
SEXP out = PROTECT(col2r(col));
setAttrib(out, install("client"), ptr_client);
UNPROTECT(1);
return out;
}
SEXP R_methods_test_MAKE_CLASS(SEXP className)
{
SEXP classNameChar = PROTECT(asChar(className));
const char *class;
class = CHAR(classNameChar);
SEXP res = MAKE_CLASS(class);
UNPROTECT(1);
return res;
}
dpoMatrix::dpoMatrix(SEXP x) {
if (!(IS_S4_OBJECT(x)))
error(_("S4 object expected but not provided"));
// FIXME: This check should be changed to an S4 inherits check, which
// should be available in Rinternals.h but isn't.
if (strcmp(CHAR(asChar(getAttrib(x, R_ClassSymbol))),
"dpoMatrix") != 0)
error(_("Object must be of class \"dpoMatrix\""));
uplo = CHAR(asChar(GET_SLOT(x, install("uplo"))));
int *dims = INTEGER(GET_SLOT(x, lme4_DimSym));
n = dims[0];
if (dims[1] != n)
error(_("Cholesky object must be a square matrix"));
X = REAL(GET_SLOT(x, lme4_xSym));
factors = GET_SLOT(x, install("factors"));
if (LENGTH(factors) && !isNewList(factors))
error(_("\"factors\" slot should be a list"));
}
SEXP R_download_curl(SEXP url, SEXP destfile, SEXP quiet, SEXP mode, SEXP ptr) {
if(!isString(url))
error("Argument 'url' must be string.");
if(!isString(destfile))
error("Argument 'destfile' must be string.");
if(!isLogical(quiet))
error("Argument 'quiet' must be TRUE/FALSE.");
if(!isString(mode))
error("Argument 'mode' must be string.");
/* get the handle */
CURL *handle = get_handle(ptr);
/* open file */
FILE *dest = fopen(CHAR(asChar(destfile)), CHAR(asChar(mode)));
if(!dest)
error("Failed to open file %s.", CHAR(asChar(destfile)));
/* set options */
curl_easy_setopt(handle, CURLOPT_URL, translateCharUTF8(asChar(url)));
curl_easy_setopt(handle, CURLOPT_NOPROGRESS, asLogical(quiet));
curl_easy_setopt(handle, CURLOPT_WRITEFUNCTION, push_disk);
curl_easy_setopt(handle, CURLOPT_WRITEDATA, dest);
/* perform blocking request */
CURLcode status = curl_easy_perform(handle);
/* cleanup */
curl_easy_setopt(handle, CURLOPT_URL, NULL);
curl_easy_setopt(handle, CURLOPT_NOPROGRESS, 1);
curl_easy_setopt(handle, CURLOPT_WRITEFUNCTION, NULL);
curl_easy_setopt(handle, CURLOPT_WRITEDATA, NULL);
fclose(dest);
if (status != CURLE_OK)
error(curl_easy_strerror(status));
/* check for success */
stop_for_status(handle);
return ScalarInteger(0);
}
SEXP
read_mtp(SEXP fname)
{
FILE *f;
char buf[MTP_BUF_SIZE], blank[1], *pres;
MTB *mtb, thisRec;
int i, j, res, nMTB = MTB_INITIAL_ENTRIES;
PROTECT(fname = asChar(fname));
#ifdef WIN32 /* force text-mode read */
if ((f = fopen(R_ExpandFileName(CHAR(fname)), "rt")) == NULL)
#else
if ((f = fopen(R_ExpandFileName(CHAR(fname)), "r")) == NULL)
#endif
error(_("unable to open file '%s': '%s'"),
CHAR(fname), strerror(errno));
if ((fgets(buf, MTP_BUF_SIZE, f) == NULL) ||
strncmp(buf, "Minitab Portable Worksheet ", 27) != 0)
error(_("file '%s' is not in Minitab Portable Worksheet format"),
CHAR(fname));
pres = fgets(buf, MTP_BUF_SIZE, f);
if(pres != buf) error(_("file read error"));
UNPROTECT(1);
mtb = Calloc(nMTB, MTB);
for (i = 0; !feof(f); i++) {
if (i >= nMTB) {
nMTB *= 2;
mtb = Realloc(mtb, nMTB, MTB);
}
thisRec = mtb[i] = Calloc(1, MTBDATC);
if (sscanf(buf, "%%%7d%7d%7d%7d%c%8c", &(thisRec->type),
&(thisRec->cnum), &(thisRec->len),
&(thisRec->dtype), blank, thisRec->name) != 6)
error(_("first record for entry %d is corrupt"), i+1);
thisRec->name[8] = '\0';
strtrim(thisRec->name); /* trim trailing white space on name */
switch (thisRec->dtype) {
case 0: /* numeric data */
thisRec->dat.ndat = Calloc(thisRec->len, double);
for (j = 0; j < thisRec->len; j++) {
res = fscanf(f, "%lg", thisRec->dat.ndat + j);
if(res == EOF) error(_("file read error"));
}
break;
default:
if (thisRec->type == 4) { /* we have a matrix so dtype is number of columns */
thisRec->dat.ndat = Calloc(thisRec->len, double);
for (j = 0; j < thisRec->len; j++) {
res = fscanf(f, "%lg", thisRec->dat.ndat + j);
if(res == EOF) error(_("file read error"));
}
} else {
error(_("non-numeric data types are not yet implemented"));
}
}
