char *
postgresGetViewDefinition(char *viewName)
{
PGresult *res = NULL;
ASSERT(postgresCatalogViewExists(viewName));
if (MAP_HAS_STRING_KEY(plugin->plugin.cache->viewDefs, viewName))
return STRING_VALUE(MAP_GET_STRING(plugin->plugin.cache->viewDefs,viewName));
// do query
ACQUIRE_MEM_CONTEXT(memContext);
res = execPrepared(NAME_GET_VIEW_DEF, singleton(createConstString(viewName)));
if (PQntuples(res) == 1)
{
Constant *def = createConstString(PQgetvalue(res,0,0));
MAP_ADD_STRING_KEY(plugin->plugin.cache->viewDefs, viewName,
def);
PQclear(res);
return STRING_VALUE(def);
}
PQclear(res);
RELEASE_MEM_CONTEXT();
return NULL;
}
int equal_p(object o1, object o2) {
if (eqv_p(o1,o2)) return 1;
if (PAIR_P(o1)) {
return PAIR_P(o2)&&equal_p(CAR(o1),CAR(o2))&&equal_p(CDR(o1),CDR(o2));
} else if (VECTOR_P(o1)) {
if (VECTOR_P(o2)) {
long max = VECTOR_LENGTH(o1);
if (max == VECTOR_LENGTH(o2)) {
object *e1 = VECTOR_ELEMENTS(o1), *e2 = VECTOR_ELEMENTS(o2);
long i;
for (i=0; i<max; i++)
if (!equal_p(e1[i],e2[i]))
return 0;
return 1;
}
}
} else if (STRING_P(o1)) {
if (STRING_P(o2)) {
long max = STRING_LENGTH(o1);
if (max == STRING_LENGTH(o2)) {
char *p1 = STRING_VALUE(o1);
char *p2 = STRING_VALUE(o2);
while (*p1 && *p2) {
if (*p1++ != *p2++) return 0;
}
return (*p1 == *p2);
}
}
}
return 0;
}
static void primop_substring_ix(long argc) {
object s1 = *sp++;
object s2 = *sp;
char *s;
TYPE_CHECK(STRING_P(s1),1,"string",s1);
TYPE_CHECK(STRING_P(s2),1,"string",s2);
s = strstr(STRING_VALUE(s1), STRING_VALUE(s2));
if (s)
*sp = MAKE_FIXNUM(s - STRING_VALUE(s1));
else
*sp = false_object;
}
object make_string_of_size(long length, int zero) {
long i;
object s = make_heap_object(STRING_TYPE,
sizeof(struct string_heap_structure) +
length + 1);
STRING_LENGTH(s) = length;
if (zero)
for (i=0; i<=length; i++) STRING_VALUE(s)[i] = '\0';
else
STRING_VALUE(s)[length] = '\0';
return s;
}
static PGresult *
execPrepared(char *qName, List *values)
{
char **params;
int i;
int nParams = LIST_LENGTH(values);
PGresult *res = NULL;
params = CALLOC(sizeof(char*),LIST_LENGTH(values));
ASSERT(postgresIsInitialized());
i = 0;
FOREACH(Constant,c,values)
params[i++] = STRING_VALUE(c);
DEBUG_LOG("run query %s with parameters <%s>",
qName, exprToSQL((Node *) values));
res = PQexecPrepared(plugin->conn,
qName,
nParams,
(const char *const *) params,
NULL,
NULL,
0);
if (PQresultStatus(res) != PGRES_TUPLES_OK)
CLOSE_RES_CONN_AND_FATAL(res, "query %s failed:\n%s", qName,
PQresultErrorMessage(res));
return res;
}
/* Given the ASCII representation of an alist in INFO->data,
store that data in the indicated package. */
void
sd_info_to_package (SESSION_INFO *info, Package *package)
{
WispObject *list;
/* The data is stored as the ASCII representation of an alist. */
list = wisp_from_string ((char *)info->data);
if (list != (WispObject *)NULL)
{
while (list != NIL)
{
WispObject *pair;
pair = CAR (list);
list = CDR (list);
if (CONS_P (pair) && STRING_P (CAR (pair)))
{
char *tag;
tag = strdup (STRING_VALUE (CAR (pair)));
if (STRING_P (CDR (pair)))
{
Symbol *sym;
sym = symbol_intern_in_package (package, tag);
symbol_add_value (sym, STRING_VALUE (CDR (pair)));
}
else
{
WispObject *values = CDR (pair);
Symbol *sym = symbol_intern_in_package (package, tag);
while (CONS_P (values) && STRING_P (CAR (values)))
{
symbol_add_value (sym, STRING_VALUE (CAR (values)));
values = CDR (values);
}
}
free (tag);
}
}
}
gc_wisp_objects ();
}
static void primop_string_ref(long argc) {
object s = *sp++;
long i = the_long(2,*sp);
TYPE_CHECK(STRING_P(s),1,"string",s);
if (i >= STRING_LENGTH(s))
error(*sp,"index out of range");
*sp = make_character(STRING_VALUE(s)[i]);
}
static void
print_entry (FILE *stream, WispObject *entry, int long_p)
{
if (!long_p)
{
char *name = (char *)NULL;
char *home_phone = (char *)NULL;
char *work_phone = (char *)NULL;
char *bday = (char *)NULL;
name = sassoc ("name:", entry);
bday = sassoc ("birthday:", entry);
if (!home_phone) home_phone = sassoc ("home:", entry);
if (!home_phone) home_phone = sassoc ("phone:", entry);
if (!work_phone) work_phone = sassoc ("work:", entry);
if (!work_phone) work_phone = sassoc ("office:", entry);
if (!work_phone) work_phone = sassoc ("pager:", entry);
fprintf (stream, "%20s: (home: %14s), (work: %14s), (bday: %s)\n",
name,
home_phone ? home_phone : "",
work_phone ? work_phone : "",
bday ? bday : "*unknown*");
}
else
{
while (entry != NIL)
{
char *tag, *value;
WispObject *pair;
pair = CAR (entry);
entry = CDR (entry);
tag = prettify (STRING_VALUE (CAR (pair)));
value = "";
if (CDR (pair) != NIL)
value = STRING_VALUE (CADR (pair));
fprintf (stream, "%14s %s\n", tag, value);
free (tag);
}
}
}
static void primop_string_set(long argc) {
object s = *sp;
long i = the_long(2,sp[1]);
char c = the_char(3,sp[2]);
TYPE_CHECK(STRING_P(s),1,"string",s);
if (i >= STRING_LENGTH(s))
error(sp[1],"index out of range");
STRING_VALUE(s)[i] = c;
sp += 2;
}
static void primop_string_append(long argc) {
long i, len = 0;
object s, result;
char *rp;
for (i=0; i<argc; i++) {
s = sp[i];
TYPE_CHECK(STRING_P(s),i+1,"string",s);
len += STRING_LENGTH(s);
}
result = make_string_of_size(len,0);
rp = STRING_VALUE(result);
for (i=0; i<argc; i++) {
char *p = STRING_VALUE(sp[i]);
while (*p) *rp++ = *p++;
}
*rp = '\0';
sp += argc;
*--sp = result;
}
static void primop_string(long argc) {
object s = make_string_of_size(argc,0);
char *p = STRING_VALUE(s);
long i;
for (i=0; i<argc; i++) {
object co = *sp++;
*p++ = the_char(i+1,co);
}
*p++ = '\0';
*--sp = s;
}
struct lispobj *subr_error(struct lispobj *args)
{
if(length(args) != 1)
return ERROR_ARGS;
struct lispobj *obj = CAR(args);
if(OBJ_TYPE(obj) != STRING)
return NEW_ERROR("Argument is not a string.\n");
return NEW_ERROR(STRING_VALUE(obj));
}
/**
* @brief Summarizes a list of vectors into a list of binned vectors of equal length. Each vector bin summarizes an approximately equal amount of values.
*
* @param method Charater array defining the method to be used for binning. Can be 'mean' 'median' or 'max'
* @param score_list List with numeric vectors
* @param window_size Window width of the vectors that will be returned
* @return List with updated vectors
* @details Walks through the vectors and calls shrink or expand to set vectors to equal widths
* @note Nothing
* @todo Nothing
*/
SEXP approx_window(SEXP window_count, SEXP score_list, SEXP method) {
const char *methodn = STRING_VALUE(method);
const int wsize=INTEGER_VALUE(window_count);
SEXP lnames = getAttrib(score_list, R_NamesSymbol);
SEXP ori_vec,new_vec,out_names,out_list;
int elcount=0,elements=LENGTH(lnames),upc=0,olen;
signal(SIGINT,SIG_DFL);
PROTECT(lnames = AS_CHARACTER(lnames));
upc++;
PROTECT(out_list = allocVector(VECSXP, elements));
upc++;
PROTECT(out_names = allocVector(STRSXP,elements));
upc++;
//Select proper call back
double (*summarizep)(int *,int,double *);
if(!strcmp(methodn,"mean")) {
summarizep=mean_dble;
} else if(!strcmp(methodn,"median")) {
summarizep=median_dble;
} else if(!strcmp(methodn,"max")) {
summarizep=vect_max_dble;
} else {
error("%s not known",methodn);
goto FINALIZE;
}
for(; elcount<elements; ++elcount) {
PROTECT(ori_vec=AS_NUMERIC(VECTOR_ELT(score_list, elcount)));
PROTECT(new_vec = NEW_NUMERIC(wsize));
olen=LENGTH(ori_vec);
double *ori_vecp= NUMERIC_POINTER(ori_vec);
double *new_vecp= NUMERIC_POINTER(new_vec);
SET_STRING_ELT(out_names,elcount,mkChar(CHAR(STRING_ELT(lnames, elcount))));
if(olen>wsize) {
shrink_dble(ori_vecp,new_vecp,olen,wsize,summarizep);
SET_VECTOR_ELT(out_list, elcount, new_vec);
} else if(olen<wsize) {
expand_dble(ori_vecp,new_vecp,olen,wsize);
SET_VECTOR_ELT(out_list, elcount, new_vec);
} else {
SET_VECTOR_ELT(out_list, elcount, ori_vec);
}
UNPROTECT(2);
}
setAttrib(out_list, R_NamesSymbol, out_names);
FINALIZE:
UNPROTECT(upc);
return(out_list);
}
static void primop_string_to_list(long argc) {
long i;
object result = null_object;
PUSH_GC_PROTECT(result);
TYPE_CHECK(STRING_P(sp[0]),1,"string", sp[0]);
i = STRING_LENGTH(sp[0]);
while (i--) {
char c = STRING_VALUE(sp[0])[i];
result = cons(make_character(c),result);
}
POP_GC_PROTECT(1);
*sp = result;
}
struct lispobj *subr_display(struct lispobj *args)
{
if(length(args) != 1)
return ERROR_ARGS;
if(CAR(args) != NULL && OBJ_TYPE(CAR(args)) == STRING) {
printf("%s", STRING_VALUE(CAR(args)));
} else {
print(CAR(args));
}
return OBJ_TRUE;
}
static void primop_substring(long argc) {
object s = sp[0], result;
long start = the_long(2,sp[1]), end = the_long(3,sp[2]);
long i, len;
char *rp, *p;
TYPE_CHECK(STRING_P(s),1,"string",s);
len = STRING_LENGTH(s);
if (start < 0 || start > len)
error(sp[1],"starting index of range");
if (end < start || end > len)
error(sp[1],"ending index of range");
result = make_string_of_size(end-start,0);
p = STRING_VALUE(sp[0]);
rp = STRING_VALUE(result);
p += start;
for (i=start; i < end; i++) {
*rp++ = *p++;
}
*rp = '\0';
sp += 2;
*sp = result;
}
struct lispobj *subr_load(struct lispobj* args)
{
if(length(args) != 1)
return ERROR_ARGS;
struct lispobj *obj = CAR(args);
if(obj == NULL || OBJ_TYPE(obj) != STRING) {
return NEW_ERROR("Argument is not a string.\n");
}
if(!load(STRING_VALUE(obj)))
return OBJ_FALSE;
return OBJ_TRUE;
}
static void primop_make_string(long argc) {
object s, o = sp[0];
long size = the_long(1,o);
if (size < 0 || size > MAX_STRING_SIZE)
error(sp[0],"too big of a size for a string");
s = make_string_of_size(size,argc!=2);
if (argc == 2) {
char *p = STRING_VALUE(s), fill;
TYPE_CHECK(CHARACTER_P(sp[1]),1,"character",sp[1]);
fill = CHARACTER_VALUE(sp[1]);
while (size--)
*p++ = fill;
*p = '\0';
}
sp += argc;
*--sp = s;
}
//#ifdef __DEBUG_HEAP__
void heap_debug_object(struct lispobj *obj)
{
if(obj == NULL) {
printf(" null pointer");
} else {
printf(" [%p ", obj);
if(OBJ_TYPE(obj) == SYMBOL) {
printf("(symbol %s) ", SYMBOL_VALUE(obj));
} else if(OBJ_TYPE(obj) == NUMBER) {
printf("(number %d) ", NUMBER_VALUE(obj));
} else if(OBJ_TYPE(obj) == STRING) {
printf("(string %s) ", STRING_VALUE(obj));
} else {
printf("(cons) ");
}
printf("%d] ", OBJ_REFS(obj));
}
}
STRING_VALUE CStringTable::ParseLine(LPCSTR str, LPCSTR skey, bool bFirst)
{
// LPCSTR str = "1 $$action_left$$ 2 $$action_right$$ 3 $$action_left$$ 4";
xr_string res;
int k = 0;
const char* b;
#define ACTION_STR "$$ACTION_"
//. int LEN = (int)xr_strlen(ACTION_STR);
#define LEN 9
string256 buff;
string256 srcbuff;
bool b_hit = false;
while( (b = strstr( str+k,ACTION_STR)) !=0 )
{
buff[0] = 0;
srcbuff[0] = 0;
res.append (str+k, b-str-k);
const char* e = strstr( b+LEN,"$$" );
int len = (int)(e-b-LEN);
strncpy (srcbuff,b+LEN, len);
srcbuff[len] = 0;
GetActionAllBinding (srcbuff, buff, sizeof(buff) );
res.append (buff, xr_strlen(buff) );
k = (int)(b-str);
k += len;
k += LEN;
k += 2;
b_hit = true;
};
if(k<(int)xr_strlen(str)){
res.append(str+k);
}
if(b_hit&&bFirst) pData->m_string_key_binding[skey] = str;
return STRING_VALUE(res.c_str());
}
static rc
testConstant (void)
{
Constant *c;
char *str;
c = createConstInt(1);
ASSERT_EQUALS_INT(1, INT_VALUE(c), "constant int 1");
c = createConstFloat(2.0);
ASSERT_EQUALS_FLOAT(2.0, FLOAT_VALUE(c), "constant float 2.0");
c = createConstBool(TRUE);
ASSERT_EQUALS_INT(TRUE, BOOL_VALUE(c), "constant boolean TRUE");
str = strdup("test");
c = createConstString(str);
ASSERT_EQUALS_STRING("test", STRING_VALUE(c), "constant string \"test\"");
return PASS;
}
SEXP R_digest(
SEXP Txt,
SEXP Algo,
SEXP Length) {
char *txt = (char *)STRING_VALUE(Txt);
int algo = INTEGER_VALUE(Algo);
int length = INTEGER_VALUE(Length);
SEXP result = R_NilValue;
static char *output, buf[41];
output = digest_string(txt, algo, length, buf);
if(output == NULL) {
error("Error in C computations of digest: %s",
(error_message == NULL) ? "<unspecified error>" : error_message);
return result;
}
PROTECT(result=allocVector(STRSXP, 1));
SET_STRING_ELT(result, 0, mkChar(output));
UNPROTECT(1);
return result;
}
void print(struct lispobj *obj)
{
#ifdef __DEBUG_PRINT__
printf("[");
#endif /* __DEBUG_PRINT__ */
if(obj == NULL) {
printf("NIL");
} else if(OBJ_TYPE(obj) == ERROR) {
printf("Error: %s", ERROR_VALUE(obj));
} else if(OBJ_TYPE(obj) == SYMBOL) {
printf("%s", SYMBOL_VALUE(obj));
} else if(OBJ_TYPE(obj) == NUMBER) {
printf("%d", NUMBER_VALUE(obj));
} else if(OBJ_TYPE(obj) == STRING) {
printf("\"%s\"", STRING_VALUE(obj));
} else {
if(CAR(obj) == NEW_SYMBOL("PROC")) {
printf("<procedure ");
if(CADR(obj) != NEW_SYMBOL("NIL")) {
print_list(CADR(obj));
} else {
printf("()");
}
printf(" %p>", CADDDR(obj));
} else if(CAR(obj) == NEW_SYMBOL("SUBR")) {
printf("<primitive-procedure %p>", CADR(obj));
} else {
print_list(obj);
}
}
#ifdef __DEBUG_PRINT__
if(obj != NULL) {
printf(" => %d]", OBJ_REFS(obj));
} else {
printf(" => nil]");
}
#endif /* __DEBUG_PRINT__ */
return;
}
static void primop_list_to_string(long argc) {
object l = sp[0];
long i, max = 0;
object s;
char *p;
while (PAIR_P(l)) {
object c = CAR(l);
if (!CHARACTER_P(c))
error(sp[0],"list contains a non-character");
max++;
l = CDR(l);
}
if (!NULL_P(l))
error(sp[0],"not a proper list");
s = make_string_of_size(max,0);
p = STRING_VALUE(s);
l = sp[0];
for (i=0; i<max; i++) {
*p++ = CHARACTER_VALUE(CAR(l));
l = CDR(l);
}
*p = '\0';
*sp = s;
}
SEXP rgenoud(SEXP fn, SEXP rho,
SEXP nvars, SEXP pop_size, SEXP max_generations, SEXP wait_generations,
SEXP n_starting_values, SEXP starting_values,
SEXP P, SEXP Domains,
SEXP max, SEXP gradient_check, SEXP boundary_enforcement,
SEXP solution_tolerance, SEXP BFGS, SEXP data_type_int,
SEXP provide_seeds, SEXP unif_seed, SEXP int_seed,
SEXP print_level, SEXP share_type, SEXP instance_number,
SEXP MemoryMatrix, SEXP Debug,
SEXP output_path, SEXP output_type, SEXP project_path,
SEXP hard_generation_limit,
SEXP fn_optim,
SEXP lexical, SEXP fnLexicalSort, SEXP fnMemoryMatrixEvaluate,
SEXP RuserGradient, SEXP fnGR,
SEXP RP9mix, SEXP BFGSburnin, SEXP transform)
{
SEXP ret;
long parameters, i, j;
double *FitValues, *Results, *Gradients;
if(!isEnvironment(rho))
error ("`rho' should be an environment");
parameters = asInteger(nvars);
// setup GENOUD
struct GND_IOstructure *MainStructure;
MainStructure = (struct GND_IOstructure *) malloc(sizeof(struct GND_IOstructure));
double **domains;
domains = (double **) malloc(parameters*sizeof(double));
for (i=0; i<parameters; i++) {
domains[i] = (double *) malloc(2*sizeof(double));
}
for (j=0; j<2; j++) {
for (i=0; i<parameters; i++) {
domains[i][j] = REAL(Domains)[i + j*parameters];
}
}
// starting values
double **StartingValues;
int nStartingValues;
nStartingValues = asInteger(n_starting_values);
if (nStartingValues > 0) {
/* need to free a matrix of StaringValues below */
StartingValues = (double **) malloc(nStartingValues*sizeof(double));
for (i=0; i<nStartingValues; i++) {
StartingValues[i] = (double *) malloc(parameters*sizeof(double));
for(j=0; j<parameters; j++)
StartingValues[i][j] = REAL(starting_values)[(i * parameters + j)];
}
}
MainStructure->fn=fn;
MainStructure->rho=rho;
MainStructure->fnLexicalSort=fnLexicalSort;
MainStructure->fnMemoryMatrixEvaluate=fnMemoryMatrixEvaluate;
MainStructure->fnGR=fnGR;
MainStructure->fn_optim=fn_optim;
MainStructure->Lexical=asInteger(lexical);
MainStructure->UserGradient=asInteger(RuserGradient);
MainStructure->nvars=parameters;
MainStructure->PopSize=asInteger(pop_size);
MainStructure->MaxGenerations=asInteger(max_generations);
MainStructure->WaitGenerations=asInteger(wait_generations);
MainStructure->HardGenerationLimit=asInteger(hard_generation_limit);
MainStructure->nStartingValues=nStartingValues;
MainStructure->StartingValues=StartingValues;
MainStructure->P[0]=REAL(P)[0];
MainStructure->P[1]=REAL(P)[1];
MainStructure->P[2]=REAL(P)[2];
MainStructure->P[3]=REAL(P)[3];
MainStructure->P[4]=REAL(P)[4];
MainStructure->P[5]=REAL(P)[5];
MainStructure->P[6]=REAL(P)[6];
MainStructure->P[7]=REAL(P)[7];
MainStructure->P[8]=REAL(P)[8];
MainStructure->Domains=domains;
MainStructure->MinMax=asInteger(max);
MainStructure->GradientCheck=asInteger(gradient_check);
MainStructure->BoundaryEnforcement=asInteger(boundary_enforcement);
MainStructure->SolutionTolerance=asReal(solution_tolerance);
MainStructure->UseBFGS=asInteger(BFGS);
MainStructure->MemoryUsage=asInteger(MemoryMatrix);
MainStructure->Debug=asInteger(Debug);
MainStructure->InstanceNumber=asInteger(instance_number);
MainStructure->ProvideSeeds=asInteger(provide_seeds);
MainStructure->UnifSeed=asInteger(unif_seed);
MainStructure->IntSeed=asInteger(int_seed);
MainStructure->PrintLevel=asInteger(print_level);
MainStructure->DataType=asInteger(data_type_int);
/*
Share Type:
(0) no reading of the existing project file and no looking at the public population file
(1) reading of any existing project file, but no examining of public population file
(2) NO reading of any existing project file but examination of public population file
(3) BOTH reading of any existing project file AND examination of public population file
*/
MainStructure->ShareType=asInteger(share_type);
//Paths
char OutputPath[1000], ProjectPath[1000];
strcpy(OutputPath,STRING_VALUE(output_path));
strcpy(ProjectPath,STRING_VALUE(project_path));
MainStructure->OutputPath=OutputPath;
MainStructure->ProjectPath=ProjectPath;
MainStructure->OutputType=asInteger(output_type);
/* output data structures */
FitValues = (double *) malloc(MainStructure->Lexical*sizeof(double));
Results = (double *) malloc(parameters*sizeof(double));
Gradients = (double *) malloc(parameters*sizeof(double));
MainStructure->oFitValues=FitValues;
MainStructure->oResults=Results;
MainStructure->oGradients=Gradients;
/* from setupGenoud */
/* output data structures */
MainStructure->oGenerations=0;
MainStructure->oPeakGeneration=0;
MainStructure->oPopSize=0;
MainStructure->ThreadNumber=0;
/* Operator Options */
MainStructure->P9mix=asReal(RP9mix);
MainStructure->BFGSburnin=asInteger(BFGSburnin);
/* Transform Related Variables */
/* whichFUN == 3 implies EvaluateTransform should be called */
/* whichFUN == 2 implies EvaluateLexical should be called */
/* whichFUN == 1 implies evaluate should be called */
MainStructure->Transform=asInteger(transform);
if(MainStructure->Transform == 1)
MainStructure->whichFUN = 3;
else if(MainStructure->Lexical > 1)
MainStructure->whichFUN = 2;
else
MainStructure->whichFUN = 1;
genoud(MainStructure);
ret = mkans(MainStructure->oFitValues,
MainStructure->oResults, MainStructure->oGradients, MainStructure->oP,
MainStructure->oGenerations, MainStructure->oPeakGeneration,
MainStructure->oPopSize, MainStructure->nvars, MainStructure->Lexical);
// Free memory
free(MainStructure);
for (i=0; i<parameters; i++)
free(domains[i]);
free(domains);
free(Results);
free(Gradients);
free(FitValues);
if (nStartingValues > 0) {
for (i=0; i<nStartingValues; i++)
free(StartingValues[i]);
free(StartingValues);
}
return(ret);
} // end of rgenoud()
/**
* @brief Main entry point for R
*
* @param bamfilenameR Filename of read container
* @param aRgvals Vector containing the user arguments
* @param filterList passed from R in the form list("chr1"=c(100,200,3000,3010...start,end...))
* @return R list in the form list("chr1"=c(1,2,1,2,1,1,...),"chr1_gind"=c(1100,1200...),"chr1_lind"=c(0,112,...),"chrX"=NA,...) and a Statistics vector
* @details All chromosome of the filter or all chromosomes in the file header will be scanned and passed to an R list
* @note
* @todo high_cov not yet implemented.
*/
SEXP construct_dc(SEXP bamfilenameR, SEXP aRgvals, SEXP filterList) {
double *statsp;//resulting statistics in the order "total reads" "coverage" "local coverage" "max score"
uint32_t upcounter=0,i=0;
time_t tstart,tstop;
global_densities_t gd={0};
user_arguments_t user_args;
filter_t ft;
SEXP histogram,stats;
int *argvalsp;
signal(SIGINT,SIG_DFL);//make this thing stop on CTRL+C
time(&tstart);
/* Set user defined values */
PROTECT(aRgvals=AS_INTEGER(aRgvals));upcounter++;
if(LENGTH(aRgvals)!=10)error("Invalid amount of arguments - arguments[%d] / should be %d!\n",LENGTH(aRgvals),9);
argvalsp=INTEGER_POINTER(aRgvals);
user_args.bamfilename = STRING_VALUE(bamfilenameR);
user_args.READTHROUGH = argvalsp[0];//bool. read from start to end and 0 take whole read whithout CIGAR splice info
user_args.PAIRED = argvalsp[1];
user_args.STRANDED = argvalsp[2];//Set to 1 / -1 it will use only forward / reverse reads respectively. 0 means all reads are processed
user_args.TMAPQ = argvalsp[3];//Minimum MPAQ score. Lower scored reads will be skipped
user_args.COLLAPSE = argvalsp[4];
user_args.EXTEND = argvalsp[5];//extend each read in its direction by this amount of BPs
user_args.HWINDOW = argvalsp[6];
user_args.COMPRESSION = argvalsp[7];//minimum BPs needed between data blocks to collapse the gap and index it
user_args.VERBOSE = argvalsp[8];
user_args.UNIQUE = argvalsp[9];
/* Try to open the file */
samfile_t *bam_file;
bam_file=open_samtools(user_args.bamfilename);
if(!bam_file){
warning("sam/bam file not found!\n");
UNPROTECT(upcounter);
return(R_NilValue);
}
if(user_args.HWINDOW>user_args.COMPRESSION){
warning("HWINDOW has to be smaller than COMPRESSION! HWINDOW updated to %d\n",user_args.COMPRESSION);
user_args.HWINDOW=user_args.COMPRESSION;
}
PROTECT(histogram = NEW_INTEGER(UINT16_MAX));upcounter++;//initialize compressed scores
gd.histogramp = (uint32_t*) INTEGER_POINTER(histogram);
for(i = 0; i < UINT16_MAX; i++) gd.histogramp[i] = 0;
gd.total_elements=bam_file->header->n_targets;//one vector per chromosome needed
/* #### CHECK IF THERE IS AN ACTIVE FILTER IN PLACE */
user_args.FILTER=isNewList(filterList) ? 1 : 0;
if(user_args.FILTER){
upcounter+=set_filter(filterList,&ft);
gd.total_elements=ft.seqn;//overwrite total elements if filter is passed, since one density is returned per slice
}
// Creating a list with vector elements as many as sequences plus a character string vector:
PROTECT(gd.list = allocVector(VECSXP, (gd.total_elements*3)+2));upcounter++;//3x for the two indexes and scores per chromosome
PROTECT(gd.list_names = allocVector(STRSXP,(gd.total_elements*3)+2));upcounter++;//+1 for statistics vector +1 for the histogram
/* PASS EVERYTHING */
write_density(&gd,&user_args,bam_file,&ft);
if(!gd.total_reads)goto NO_READS_FOUND;
// 1 total_reads 2 gcoverage 3 lcoverage 4 maxscore 5 lmaxscore 6 lowqual 7 filtered 8 collapsed 9 paired 10 proper_pairs 11 pos 12 neg 13 fmapmass 14 lsize 15 gsize
SET_STRING_ELT(gd.list_names,gd.total_elements*3,mkChar("Statistics"));
PROTECT(stats = NEW_NUMERIC(15));upcounter++;
statsp = NUMERIC_POINTER(stats);
*statsp++=(double)gd.total_reads;
*statsp++=(double)gd.mapmass/(double)gd.gsize;
*statsp++=(double)gd.lmapmass/(double)gd.lsize;
*statsp++=(double)gd.maxscore;
*statsp++=(double)gd.lmaxScore;
*statsp++=(double)gd.lowqual;
*statsp++=(double)gd.filtered_reads;
*statsp++=(double)gd.collapsed;
*statsp++=(double)gd.paired;
*statsp++=(double)gd.ppairs/2;
*statsp++=(double)gd.pos_strand;
*statsp++=(double)gd.neg_strand;
*statsp=(double)gd.mapmass;
*statsp++=(double)gd.lsize;
*statsp++=(double)gd.gsize;
if(gd.lmaxScore>=umaxof(usersize)-1){
warning("\nThe maximum pile up is exceeding the maximal value of UINT16_MAX=%d. Reads have been capped to that value.\nConsider to rerun using the maxDups option!\n",UINT16_MAX);
}
SET_VECTOR_ELT(gd.list,gd.total_elements*3, stats);
SET_STRING_ELT(gd.list_names,(gd.total_elements*3)+1,mkChar("Histogram"));
SET_VECTOR_ELT(gd.list,(gd.total_elements*3)+1,histogram);
setAttrib(gd.list, R_NamesSymbol, gd.list_names);
NO_READS_FOUND:
time(&tstop);
if(user_args.VERBOSE>0)printf("About %.0f seconds passed. %llu reads processed \n", difftime(tstop, tstart),gd.total_reads);
close_bamfile(bam_file);
if(user_args.FILTER)destroy_filter(&ft);
UNPROTECT(upcounter+gd.upcounter);
if(!gd.total_reads)return(R_NilValue);
else return(gd.list);
}
static long string_ci_compare(object s1, object s2) {
TYPE_CHECK(STRING_P(s1),1,"string",s1);
TYPE_CHECK(STRING_P(s2),2,"string",s2);
return strcmpci(STRING_VALUE(s1), STRING_VALUE(s2));
}
int main (int argc,char *argv[])
{/* Main */
double *f=NULL;
int i;
char *pp=NULL;
FILE *fout=NULL;
SEXP e, e1, rv, rs;
init_R(argc, argv);
/* Calling R and asking it to call compiled C routines! */
{
int deuce=-999;
DllInfo *info;
R_CallMethodDef callMethods[] = {
{"callback", (DL_FUNC) &callback, 1},
{NULL, NULL, 0}
};
info = R_getEmbeddingDllInfo();
R_registerRoutines(info, NULL, callMethods, NULL, NULL);
/* .Call is the R function used to call compiled
code that uses internal R objects */
PROTECT(e1=lang3( install(".Call"),
mkString("callback"),ScalarInteger(100)));
/* evaluate the R command in the global environment*/
PROTECT(e=eval(e1,R_GlobalEnv));
/* show the value */
printf("Answer returned by R:"); Rf_PrintValue(e);
/* store the value in a local variable */
deuce = INTEGER(e)[0];
printf("Got %d back from result SEXP\n\n", deuce);
UNPROTECT(2); /* allow for R's garbage collection */
}
/* Calling R and asking it to do computation on a C array */
f = (double *)malloc(sizeof(double)*256);
for (i=0; i<256;++i) f[i]=(double)rand()/(double)RAND_MAX+i/64;
/*Now copy array into R structs */
PROTECT(rv=allocVector(REALSXP, 256));
defineVar(install("f"), rv, R_GlobalEnv); /* put rv in R's environment and
name it "f" */
for (i=0; i<256;++i) REAL(rv)[i] = f[i]; /* fill rv with values */
/* plot that array with R's: plot(f) */
PROTECT(e = lang1(install("x11")));
eval(e, R_GlobalEnv);
UNPROTECT(1);
PROTECT(e=lang2(install("plot"),install("f")));
eval(e, R_GlobalEnv);
UNPROTECT(1);
/* calculate the log of the values with log(f) */
PROTECT(e1=lang2(install("log"),install("f")));
PROTECT(e=eval(e1,R_GlobalEnv));
for (i=0; i<256;++i) {
if (i<5 || i>250) {
printf("%d: log(%f)=%f\n", i, f[i], REAL(e)[i]);
} else if (!(i%20)) {
printf("...");
}
}
UNPROTECT(2);
/* Now run some R script with source(".../ExamineXmat.R") */
if (!(pp = Add_plausible_path("ExamineXmat.R"))) {
fprintf(stderr,"Failed to find ExamineXmat.R\n");
exit(1);
}
PROTECT(rs=mkString(pp));
defineVar(install("sss"), rs, R_GlobalEnv);
fprintf(stderr,"checking on script name: %s\n", STRING_VALUE(rs));
PROTECT(e=lang2(install("source"),install("sss")));
eval(e, R_GlobalEnv);
UNPROTECT(2);
fprintf(stderr,"Hit enter to proceed\n");
free(pp); pp=NULL;
/* Here is should test calling R functions from some functions
that we create. I will need to sort out how packges are formed
for R and how R can find them on any machine etc. Nuts and bolts...
A simple exercise here would be to learn how to construct our R library
and call its functions from here ... */
free(f); f = NULL; free(pp); pp=NULL;
getchar();
}
SEXP xmethas(
SEXP ncif,
SEXP cifname,
SEXP beta,
SEXP ipar,
SEXP iparlen,
SEXP period,
SEXP xprop,
SEXP yprop,
SEXP mprop,
SEXP ntypes,
SEXP nrep,
SEXP p,
SEXP q,
SEXP nverb,
SEXP nrep0,
SEXP x,
SEXP y,
SEXP marks,
SEXP ncond,
SEXP fixall,
SEXP track,
SEXP thin,
SEXP snoopenv,
SEXP temper,
SEXP invertemp)
{
char *cifstring;
double cvd, cvn, qnodds, anumer, adenom, betavalue;
double *iparvector;
int verb, marked, tempered, mustupdate, itype;
int nfree, nsuspect;
int irep, ix, j, maxchunk, iverb;
int Ncif;
int *plength;
long Nmore;
int permitted;
double invtemp;
double *xx, *yy, *xpropose, *ypropose;
int *mm, *mpropose, *pp, *aa;
SEXP out, xout, yout, mout, pout, aout;
int tracking, thinstart;
#ifdef HISTORY_INCLUDES_RATIO
SEXP numout, denout;
double *nn, *dd;
#endif
State state;
Model model;
Algor algo;
Propo birthprop, deathprop, shiftprop;
History history;
Snoop snooper;
/* The following variables are used only for a non-hybrid interaction */
Cifns thecif; /* cif structure */
Cdata *thecdata; /* pointer to initialised cif data block */
/* The following variables are used only for a hybrid interaction */
Cifns *cif; /* vector of cif structures */
Cdata **cdata; /* vector of pointers to initialised cif data blocks */
int *needupd; /* vector of logical values */
int k; /* loop index for cif's */
/* =================== Protect R objects from garbage collector ======= */
PROTECT(ncif = AS_INTEGER(ncif));
PROTECT(cifname = AS_CHARACTER(cifname));
PROTECT(beta = AS_NUMERIC(beta));
PROTECT(ipar = AS_NUMERIC(ipar));
PROTECT(iparlen = AS_INTEGER(iparlen));
PROTECT(period = AS_NUMERIC(period));
PROTECT(xprop = AS_NUMERIC(xprop));
PROTECT(yprop = AS_NUMERIC(yprop));
PROTECT(mprop = AS_INTEGER(mprop));
PROTECT(ntypes = AS_INTEGER(ntypes));
PROTECT(nrep = AS_INTEGER(nrep));
PROTECT( p = AS_NUMERIC(p));
PROTECT( q = AS_NUMERIC(q));
PROTECT(nverb = AS_INTEGER(nverb));
PROTECT(nrep0 = AS_INTEGER(nrep0));
PROTECT( x = AS_NUMERIC(x));
PROTECT( y = AS_NUMERIC(y));
PROTECT( marks = AS_INTEGER(marks));
PROTECT(fixall = AS_INTEGER(fixall));
PROTECT(ncond = AS_INTEGER(ncond));
PROTECT(track = AS_INTEGER(track));
PROTECT(thin = AS_INTEGER(thin));
PROTECT(temper = AS_INTEGER(temper));
PROTECT(invertemp = AS_NUMERIC(invertemp));
/* that's 24 protected objects */
/* =================== Translate arguments from R to C ================ */
/*
Ncif is the number of cif's
plength[i] is the number of interaction parameters in the i-th cif
*/
Ncif = *(INTEGER_POINTER(ncif));
plength = INTEGER_POINTER(iparlen);
/* copy RMH algorithm parameters */
algo.nrep = *(INTEGER_POINTER(nrep));
algo.nverb = *(INTEGER_POINTER(nverb));
algo.nrep0 = *(INTEGER_POINTER(nrep0));
algo.p = *(NUMERIC_POINTER(p));
algo.q = *(NUMERIC_POINTER(q));
algo.fixall = ((*(INTEGER_POINTER(fixall))) == 1);
algo.ncond = *(INTEGER_POINTER(ncond));
algo.tempered = tempered = (*(INTEGER_POINTER(temper)) != 0);
algo.invtemp = invtemp = *(NUMERIC_POINTER(invertemp));
/* copy model parameters without interpreting them */
model.beta = NUMERIC_POINTER(beta);
model.ipar = iparvector = NUMERIC_POINTER(ipar);
model.period = NUMERIC_POINTER(period);
model.ntypes = *(INTEGER_POINTER(ntypes));
state.ismarked = marked = (model.ntypes > 1);
/* copy initial state */
state.npts = LENGTH(x);
state.npmax = 4 * ((state.npts > 256) ? state.npts : 256);
state.x = (double *) R_alloc(state.npmax, sizeof(double));
state.y = (double *) R_alloc(state.npmax, sizeof(double));
xx = NUMERIC_POINTER(x);
yy = NUMERIC_POINTER(y);
if(marked) {
state.marks =(int *) R_alloc(state.npmax, sizeof(int));
mm = INTEGER_POINTER(marks);
}
if(!marked) {
for(j = 0; j < state.npts; j++) {
state.x[j] = xx[j];
state.y[j] = yy[j];
}
} else {
for(j = 0; j < state.npts; j++) {
state.x[j] = xx[j];
state.y[j] = yy[j];
state.marks[j] = mm[j];
}
}
#if MH_DEBUG
Rprintf("\tnpts=%d\n", state.npts);
#endif
/* access proposal data */
xpropose = NUMERIC_POINTER(xprop);
ypropose = NUMERIC_POINTER(yprop);
mpropose = INTEGER_POINTER(mprop);
/* we need to initialise 'mpropose' to keep compilers happy.
mpropose is only used for marked patterns.
Note 'mprop' is always a valid pointer */
/* ================= Allocate space for cifs etc ========== */
if(Ncif > 1) {
cif = (Cifns *) R_alloc(Ncif, sizeof(Cifns));
cdata = (Cdata **) R_alloc(Ncif, sizeof(Cdata *));
needupd = (int *) R_alloc(Ncif, sizeof(int));
} else {
/* Keep the compiler happy */
cif = (Cifns *) R_alloc(1, sizeof(Cifns));
cdata = (Cdata **) R_alloc(1, sizeof(Cdata *));
needupd = (int *) R_alloc(1, sizeof(int));
}
/* ================= Determine process to be simulated ========== */
/* Get the cif's */
if(Ncif == 1) {
cifstring = (char *) STRING_VALUE(cifname);
thecif = getcif(cifstring);
mustupdate = NEED_UPDATE(thecif);
if(thecif.marked && !marked)
fexitc("cif is for a marked point process, but proposal data are not marked points; bailing out.");
/* Keep compiler happy*/
cif[0] = thecif;
needupd[0] = mustupdate;
} else {
mustupdate = NO;
for(k = 0; k < Ncif; k++) {
cifstring = (char *) CHAR(STRING_ELT(cifname, k));
cif[k] = getcif(cifstring);
needupd[k] = NEED_UPDATE(cif[k]);
if(needupd[k])
mustupdate = YES;
if(cif[k].marked && !marked)
fexitc("component cif is for a marked point process, but proposal data are not marked points; bailing out.");
}
}
/* ============= Initialise transition history ========== */
tracking = (*(INTEGER_POINTER(track)) != 0);
/* Initialise even if not needed, to placate the compiler */
if(tracking) { history.nmax = algo.nrep; } else { history.nmax = 1; }
history.n = 0;
history.proptype = (int *) R_alloc(history.nmax, sizeof(int));
history.accepted = (int *) R_alloc(history.nmax, sizeof(int));
#ifdef HISTORY_INCLUDES_RATIO
history.numerator = (double *) R_alloc(history.nmax, sizeof(double));
history.denominator = (double *) R_alloc(history.nmax, sizeof(double));
#endif
/* ============= Visual debugging ========== */
/* Active if 'snoopenv' is an environment */
#if MH_DEBUG
Rprintf("Initialising mhsnoop\n");
#endif
initmhsnoop(&snooper, snoopenv);
#if MH_DEBUG
Rprintf("Initialised\n");
if(snooper.active) Rprintf("Debugger is active.\n");
#endif
/* ================= Thinning of initial state ==================== */
thinstart = (*(INTEGER_POINTER(thin)) != 0);
/* ================= Initialise algorithm ==================== */
/* Interpret the model parameters and initialise auxiliary data */
if(Ncif == 1) {
thecdata = (*(thecif.init))(state, model, algo);
/* keep compiler happy */
cdata[0] = thecdata;
} else {
for(k = 0; k < Ncif; k++) {
if(k > 0)
model.ipar += plength[k-1];
cdata[k] = (*(cif[k].init))(state, model, algo);
}
/* keep compiler happy */
thecdata = cdata[0];
}
/* Set the fixed elements of the proposal objects */
birthprop.itype = BIRTH;
deathprop.itype = DEATH;
shiftprop.itype = SHIFT;
birthprop.ix = NONE;
if(!marked)
birthprop.mrk = deathprop.mrk = shiftprop.mrk = NONE;
/* Set up some constants */
verb = (algo.nverb !=0);
qnodds = (1.0 - algo.q)/algo.q;
/* Set value of beta for unmarked process */
/* (Overwritten for marked process, but keeps compiler happy) */
betavalue = model.beta[0];
/* ============= Run Metropolis-Hastings ================== */
/* Initialise random number generator */
GetRNGstate();
/*
Here comes the code for the M-H loop.
The basic code (in mhloop.h) is #included many times using different options
The C preprocessor descends through a chain of files
mhv1.h, mhv2.h, ...
to enumerate all possible combinations of flags.
*/
#include "mhv1.h"
/* relinquish random number generator */
PutRNGstate();
/* ============= Done ================== */
/* Create space for output, and copy final state */
/* Point coordinates */
PROTECT(xout = NEW_NUMERIC(state.npts));
PROTECT(yout = NEW_NUMERIC(state.npts));
xx = NUMERIC_POINTER(xout);
yy = NUMERIC_POINTER(yout);
for(j = 0; j < state.npts; j++) {
xx[j] = state.x[j];
yy[j] = state.y[j];
}
/* Marks */
if(marked) {
PROTECT(mout = NEW_INTEGER(state.npts));
mm = INTEGER_POINTER(mout);
for(j = 0; j < state.npts; j++)
mm[j] = state.marks[j];
} else {
/* Keep the compiler happy */
PROTECT(mout = NEW_INTEGER(1));
mm = INTEGER_POINTER(mout);
mm[0] = 0;
}
/* Transition history */
if(tracking) {
PROTECT(pout = NEW_INTEGER(algo.nrep));
PROTECT(aout = NEW_INTEGER(algo.nrep));
pp = INTEGER_POINTER(pout);
aa = INTEGER_POINTER(aout);
for(j = 0; j < algo.nrep; j++) {
pp[j] = history.proptype[j];
aa[j] = history.accepted[j];
}
#ifdef HISTORY_INCLUDES_RATIO
PROTECT(numout = NEW_NUMERIC(algo.nrep));
PROTECT(denout = NEW_NUMERIC(algo.nrep));
nn = NUMERIC_POINTER(numout);
dd = NUMERIC_POINTER(denout);
for(j = 0; j < algo.nrep; j++) {
nn[j] = history.numerator[j];
dd[j] = history.denominator[j];
}
#endif
} else {
/* Keep the compiler happy */
PROTECT(pout = NEW_INTEGER(1));
PROTECT(aout = NEW_INTEGER(1));
pp = INTEGER_POINTER(pout);
aa = INTEGER_POINTER(aout);
pp[0] = aa[0] = 0;
#ifdef HISTORY_INCLUDES_RATIO
PROTECT(numout = NEW_NUMERIC(1));
PROTECT(denout = NEW_NUMERIC(1));
nn = NUMERIC_POINTER(numout);
dd = NUMERIC_POINTER(denout);
nn[0] = dd[0] = 0;
#endif
}
/* Pack up into list object for return */
if(!tracking) {
/* no transition history */
if(!marked) {
PROTECT(out = NEW_LIST(2));
SET_VECTOR_ELT(out, 0, xout);
SET_VECTOR_ELT(out, 1, yout);
} else {
PROTECT(out = NEW_LIST(3));
SET_VECTOR_ELT(out, 0, xout);
SET_VECTOR_ELT(out, 1, yout);
SET_VECTOR_ELT(out, 2, mout);
}
} else {
/* transition history */
if(!marked) {
#ifdef HISTORY_INCLUDES_RATIO
PROTECT(out = NEW_LIST(6));
#else
PROTECT(out = NEW_LIST(4));
#endif
SET_VECTOR_ELT(out, 0, xout);
SET_VECTOR_ELT(out, 1, yout);
SET_VECTOR_ELT(out, 2, pout);
SET_VECTOR_ELT(out, 3, aout);
#ifdef HISTORY_INCLUDES_RATIO
SET_VECTOR_ELT(out, 4, numout);
SET_VECTOR_ELT(out, 5, denout);
#endif
} else {
#ifdef HISTORY_INCLUDES_RATIO
PROTECT(out = NEW_LIST(7));
#else
PROTECT(out = NEW_LIST(5));
#endif
SET_VECTOR_ELT(out, 0, xout);
SET_VECTOR_ELT(out, 1, yout);
SET_VECTOR_ELT(out, 2, mout);
SET_VECTOR_ELT(out, 3, pout);
SET_VECTOR_ELT(out, 4, aout);
#ifdef HISTORY_INCLUDES_RATIO
SET_VECTOR_ELT(out, 5, numout);
SET_VECTOR_ELT(out, 6, denout);
#endif
}
}
#ifdef HISTORY_INCLUDES_RATIO
UNPROTECT(32); /* 24 arguments plus xout, yout, mout, pout, aout, out,
numout, denout */
#else
UNPROTECT(30); /* 24 arguments plus xout, yout, mout, pout, aout, out */
#endif
return(out);
}
SEXP digest(SEXP Txt, SEXP Algo, SEXP Length, SEXP Skip, SEXP Leave_raw) {
FILE *fp=0;
char *txt;
int algo = INTEGER_VALUE(Algo);
int length = INTEGER_VALUE(Length);
int skip = INTEGER_VALUE(Skip);
int leaveRaw = INTEGER_VALUE(Leave_raw);
SEXP result = NULL;
char output[128+1], *outputp = output; /* 33 for md5, 41 for sha1, 65 for sha256, 128 for sha512; plus trailing NULL */
int nChar;
int output_length = -1;
if (IS_RAW(Txt)) { /* Txt is either RAW */
txt = (char*) RAW(Txt);
nChar = LENGTH(Txt);
} else { /* or a string */
txt = (char*) STRING_VALUE(Txt);
nChar = strlen(txt);
}
if (skip>0) {
if (skip>=nChar) nChar=0;
else {
nChar -= skip;
txt += skip;
}
}
if (length>=0 && length<nChar) nChar = length;
switch (algo) {
case 1: { /* md5 case */
md5_context ctx;
output_length = 16;
unsigned char md5sum[16];
int j;
md5_starts( &ctx );
md5_update( &ctx, (uint8 *) txt, nChar);
md5_finish( &ctx, md5sum );
memcpy(output, md5sum, 16);
if (!leaveRaw)
for(j = 0; j < 16; j++)
sprintf(output + j * 2, "%02x", md5sum[j]);
break;
}
case 2: { /* sha1 case */
int j;
sha1_context ctx;
output_length = 20;
unsigned char sha1sum[20];
sha1_starts( &ctx );
sha1_update( &ctx, (uint8 *) txt, nChar);
sha1_finish( &ctx, sha1sum );
memcpy(output, sha1sum, 20);
if (!leaveRaw)
for( j = 0; j < 20; j++ )
sprintf( output + j * 2, "%02x", sha1sum[j] );
break;
}
case 3: { /* crc32 case */
unsigned long val, l;
l = nChar;
val = digest_crc32(0L, 0, 0);
val = digest_crc32(val, (unsigned char*) txt, (unsigned) l);
sprintf(output, "%2.2x", (unsigned int) val);
break;
}
case 4: { /* sha256 case */
int j;
sha256_context ctx;
output_length = 32;
unsigned char sha256sum[32];
sha256_starts( &ctx );
sha256_update( &ctx, (uint8 *) txt, nChar);
sha256_finish( &ctx, sha256sum );
memcpy(output, sha256sum, 32);
if(!leaveRaw)
for( j = 0; j < 32; j++ )
sprintf( output + j * 2, "%02x", sha256sum[j] );
break;
}
case 5: { /* sha2-512 case */
int j;
SHA512_CTX ctx;
output_length = SHA512_DIGEST_LENGTH;
uint8_t sha512sum[output_length], *d = sha512sum;
SHA512_Init(&ctx);
SHA512_Update(&ctx, (uint8 *) txt, nChar);
// Calling SHA512_Final, because SHA512_End will already
// convert the hash to a string, and we also want RAW
SHA512_Final(sha512sum, &ctx);
memcpy(output, sha512sum, output_length);
// adapted from SHA512_End
if(!leaveRaw) {
for (j = 0; j < output_length; j++) {
*outputp++ = sha2_hex_digits[(*d & 0xf0) >> 4];
*outputp++ = sha2_hex_digits[*d & 0x0f];
d++;
}
*outputp = (char)0;
}
break;
}
case 101: { /* md5 file case */
int j;
md5_context ctx;
output_length = 16;
unsigned char buf[1024];
unsigned char md5sum[16];
if (!(fp = fopen(txt,"rb"))) {
error("Cannot open input file: %s", txt);
return(NULL);
}
if (skip > 0) fseek(fp, skip, SEEK_SET);
md5_starts( &ctx );
if (length>=0) {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0
&& length>0) {
if (nChar>length) nChar=length;
md5_update( &ctx, buf, nChar );
length -= nChar;
}
} else {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0)
md5_update( &ctx, buf, nChar );
}
fclose(fp);
md5_finish( &ctx, md5sum );
memcpy(output, md5sum, 16);
if (!leaveRaw)
for(j = 0; j < 16; j++)
sprintf(output + j * 2, "%02x", md5sum[j]);
break;
}
case 102: { /* sha1 file case */
int j;
sha1_context ctx;
output_length = 20;
unsigned char buf[1024];
unsigned char sha1sum[20];
if (!(fp = fopen(txt,"rb"))) {
error("Cannot open input file: %s", txt);
return(NULL);
}
if (skip > 0) fseek(fp, skip, SEEK_SET);
sha1_starts ( &ctx );
if (length>=0) {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0
&& length>0) {
if (nChar>length) nChar=length;
sha1_update( &ctx, buf, nChar );
length -= nChar;
}
} else {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0)
sha1_update( &ctx, buf, nChar );
}
fclose(fp);
sha1_finish ( &ctx, sha1sum );
memcpy(output, sha1sum, 20);
if(!leaveRaw)
for( j = 0; j < 20; j++ )
sprintf( output + j * 2, "%02x", sha1sum[j] );
break;
}
case 103: { /* crc32 file case */
unsigned char buf[1024];
unsigned long val;
if (!(fp = fopen(txt,"rb"))) {
error("Cannot open input file: %s", txt);
return(NULL);
}
if (skip > 0) fseek(fp, skip, SEEK_SET);
val = digest_crc32(0L, 0, 0);
if (length>=0) {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0
&& length>0) {
if (nChar>length) nChar=length;
val = digest_crc32(val , buf, (unsigned) nChar);
length -= nChar;
}
} else {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0)
val = digest_crc32(val , buf, (unsigned) nChar);
}
fclose(fp);
sprintf(output, "%2.2x", (unsigned int) val);
break;
}
case 104: { /* sha256 file case */
int j;
sha256_context ctx;
output_length = 32;
unsigned char buf[1024];
unsigned char sha256sum[32];
if (!(fp = fopen(txt,"rb"))) {
error("Cannot open input file: %s", txt);
return(NULL);
}
if (skip > 0) fseek(fp, skip, SEEK_SET);
sha256_starts ( &ctx );
if (length>=0) {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0
&& length>0) {
if (nChar>length) nChar=length;
sha256_update( &ctx, buf, nChar );
length -= nChar;
}
} else {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0)
sha256_update( &ctx, buf, nChar );
}
fclose(fp);
sha256_finish ( &ctx, sha256sum );
memcpy(output, sha256sum, 32);
if(!leaveRaw)
for( j = 0; j < 32; j++ )
sprintf( output + j * 2, "%02x", sha256sum[j] );
break;
}
case 105: { /* sha2-512 file case */
int j;
SHA512_CTX ctx;
output_length = SHA512_DIGEST_LENGTH;
uint8_t sha512sum[output_length], *d = sha512sum;
unsigned char buf[1024];
if (!(fp = fopen(txt,"rb"))) {
error("Cannot open input file: %s", txt);
return(NULL);
}
if (skip > 0) fseek(fp, skip, SEEK_SET);
SHA512_Init(&ctx);
if (length>=0) {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0
&& length>0) {
if (nChar>length) nChar=length;
SHA512_Update( &ctx, buf, nChar );
length -= nChar;
}
} else {
while( ( nChar = fread( buf, 1, sizeof( buf ), fp ) ) > 0)
SHA512_Update( &ctx, buf, nChar );
}
fclose(fp);
// Calling SHA512_Final, because SHA512_End will already
// convert the hash to a string, and we also want RAW
SHA512_Final(sha512sum, &ctx);
memcpy(output, sha512sum, output_length);
// adapted from SHA512_End
if(!leaveRaw) {
for (j = 0; j < output_length; j++) {
*outputp++ = sha2_hex_digits[(*d & 0xf0) >> 4];
*outputp++ = sha2_hex_digits[*d & 0x0f];
d++;
}
*outputp = (char)0;
}
break;
}
default: {
error("Unsupported algorithm code");
return(NULL);
}
}
if (leaveRaw && output_length > 0) {
PROTECT(result=allocVector(RAWSXP, output_length));
memcpy(RAW(result), output, output_length);
} else {
PROTECT(result=allocVector(STRSXP, 1));
SET_STRING_ELT(result, 0, mkChar(output));
}
UNPROTECT(1);
return result;
}