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); }