Boolean THD_write_nimlatr( THD_datablock *blk ) /* 01 Jun 2005 */
{
NI_stream ns ;
NI_group *ngr ;
char sname[2048] ;
THD_3dim_dataset *dset ;
ENTRY("THD_write_nimlatr") ;
/* get dataset that contains this datablock */
dset = (THD_3dim_dataset *)blk->parent ;
if( !ISVALID_DSET(dset) ){
STATUS("parent is not valid dataset!"); RETURN(False); /* bad */
}
/* convert dataset struct AFNI attributes into a NIML element */
ngr = THD_nimlize_dsetatr( dset ) ;
if( ngr == NULL ){
STATUS("can't create NIML header element!"); RETURN(False); /* bad */
}
NI_set_attribute( ngr , "self_prefix" , blk->diskptr->prefix ) ;
/* open output NIML stream (to file) */
sprintf(sname,"file:%s",blk->diskptr->header_name) ;
ns = NI_stream_open( sname , "w" ) ;
if( ns == (NI_stream)NULL ){
STATUS("can't open output NIML stream!"); RETURN(False); /* bad */
}
/* write XML header and then the AFNI header element */
STATUS("writing NIML header") ;
NI_stream_writestring( ns , "<?xml version='1.0' ?>\n" ) ;
NI_write_element( ns , ngr , NI_TEXT_MODE ) ;
NI_stream_close( ns ) ;
RETURN(True) ;
}
SEXP R_THD_load_dset(SEXP Sfname, SEXP Opts)
{
SEXP Rdset, brik, head, names, opt, node_list=R_NilValue;
int i=0, ip=0, sb, cnt=0, *iv=NULL, kparts=2;
char *fname = NULL, *head_str;
NI_group *ngr=NULL;
NI_element *nel=NULL;
char *listels[3] = {"head","brk","index_list"}; /* the brk is on purpose
for backward compatibility */
double *dv=NULL;
float *fv=NULL;
THD_3dim_dataset *dset = NULL;
int debug=0;
if (!debug) debug = get_odebug();
/* get the options list, maybe */
PROTECT(Opts = AS_LIST(Opts));
if ((opt = getListElement(Opts,"debug")) != R_NilValue) {
debug = (int)INTEGER_VALUE(opt);
if (debug>2) set_odebug(debug);
if (debug>1) INFO_message("Debug is %d\n", debug);
}
/* get the filename */
PROTECT(Sfname = AS_CHARACTER(Sfname));
fname = R_alloc(strlen(CHAR(STRING_ELT(Sfname,0)))+1, sizeof(char));
strcpy(fname, CHAR(STRING_ELT(Sfname,0)));
/* open dset */
dset = THD_open_dataset(fname);
if (dset) {
if (debug > 1) INFO_message("Dset %s was loaded 2\n", fname);
} else {
ERROR_message("Dset %s could not be loaded\n", fname);
UNPROTECT(2);
return(R_NilValue);
}
/* form one long header string */
ngr = THD_nimlize_dsetatr(dset);
PROTECT(head = allocVector(STRSXP, ngr->part_num));
for (ip=0,i=0; i<ngr->part_num; ++i) {
switch( ngr->part_typ[i] ){
/*-- a sub-group ==> recursion! --*/
case NI_GROUP_TYPE:
break ;
case NI_ELEMENT_TYPE:
nel = (NI_element *)ngr->part[i] ;
head_str = NI_write_element_tostring(nel);
if (debug > 1) fprintf(stderr,"%s\n", head_str);
SET_STRING_ELT(head, ip, mkChar(head_str)); ++ip;
free(head_str);
break;
default:
break;
}
}
NI_free_element(ngr);
if (debug > 1) fprintf(stderr,"Forming data array of %d elements\n",
DSET_NVOX(dset)*DSET_NVALS(dset));
/* form one long array of data */
PROTECT(brik = NEW_NUMERIC(DSET_NVOX(dset)*DSET_NVALS(dset)));
dv = NUMERIC_POINTER(brik);
EDIT_floatize_dataset(dset);
for (cnt=0, sb=0; sb<DSET_NVALS(dset); ++sb) {
if (!(fv = (float *)DSET_BRICK_ARRAY(dset,sb))) {
ERROR_message("NULL brick array %d!\n", sb);
UNPROTECT(4);
return(R_NilValue);
}
if (debug > 1) fprintf(stderr,"Filling sb %d\n", sb);
for (i=0; i<DSET_NVOX(dset); ++i) {
dv[cnt++] = fv[i];
if (debug > 1) {
if (debug > 2 || i<10) {
fprintf(stderr,"%f\t", fv[i]);
}
}
}
if (debug == 2) fprintf(stderr,"...\n");
else if (debug > 2) fprintf(stderr,"\n");
}
/* how about an index list ? */
if (dset->dblk->nnodes && dset->dblk->node_list) {
if (debug > 1)
fprintf(stderr,"Copying %d node indices\n", dset->dblk->nnodes);
PROTECT(node_list = NEW_INTEGER(dset->dblk->nnodes));
iv = INTEGER_POINTER(node_list);
memcpy(iv, dset->dblk->node_list, dset->dblk->nnodes*sizeof(int));
kparts = 3;
} else {
kparts = 2;
if (debug > 1)
fprintf(stderr,"No node indices %d %p\n",
dset->dblk->nnodes, dset->dblk->node_list);
}
/* done with dset, dump it */
DSET_delete(dset);
/* form output list */
PROTECT(names = allocVector(STRSXP,kparts));
for (i=0; i<kparts; ++i) {
SET_STRING_ELT(names, i, mkChar(listels[i]));
}
PROTECT(Rdset = allocVector(VECSXP,kparts));
SET_VECTOR_ELT(Rdset, 0, head);
SET_VECTOR_ELT(Rdset, 1, brik);
if (node_list != R_NilValue) SET_VECTOR_ELT(Rdset, 2, node_list);
setAttrib(Rdset, R_NamesSymbol, names);
if (debug > 1) fprintf(stderr,"Unprotecting...\n");
if (kparts==3) UNPROTECT(7);
else UNPROTECT(6);
return(Rdset);
}
