示例#1
0
/*
 * Server routine to read requests and process them.
 * Commands are:
 *	Tname	- Transmit file if out of date
 *	Vname	- Verify if file out of date or not
 *	Qname	- Query if file exists. Return mtime & size if it does.
 */
void
server()
{
	char cmdbuf[BUFSIZ];
	register char *cp;

	signal(SIGHUP, cleanup);
	signal(SIGINT, cleanup);
	signal(SIGQUIT, cleanup);
	signal(SIGTERM, cleanup);
	signal(SIGPIPE, cleanup);

	rem = 0;
	oumask = umask(0);
	(void) sprintf(buf, "V%d\n", VERSION);
	(void) write(rem, buf, strlen(buf));

	for (;;) {
		cp = cmdbuf;
		if (read(rem, cp, 1) <= 0)
			return;
		if (*cp++ == '\n') {
			error("server: expected control record\n");
			continue;
		}
		do {
			if (read(rem, cp, 1) != 1)
				cleanup(0);
		} while (*cp++ != '\n' && cp < &cmdbuf[BUFSIZ]);
		*--cp = '\0';
		cp = cmdbuf;
		switch (*cp++) {
		case 'T':  /* init target file/directory name */
			catname = 1;	/* target should be directory */
			goto dotarget;

		case 't':  /* init target file/directory name */
			catname = 0;
		dotarget:
			if (exptilde(target, cp) == NULL)
				continue;
			tp = target;
			while (*tp)
				tp++;
			ack();
			continue;

		case 'R':  /* Transfer a regular file. */
			recvf(cp, S_IFREG);
			continue;

		case 'D':  /* Transfer a directory. */
			recvf(cp, S_IFDIR);
			continue;

		case 'K':  /* Transfer symbolic link. */
			recvf(cp, S_IFLNK);
			continue;

		case 'k':  /* Transfer hard link. */
			hardlink(cp);
			continue;

		case 'E':  /* End. (of directory) */
			*tp = '\0';
			if (catname <= 0) {
				error("server: too many 'E's\n");
				continue;
			}
			tp = stp[--catname];
			*tp = '\0';
			ack();
			continue;

		case 'C':  /* Clean. Cleanup a directory */
			clean(cp);
			continue;

		case 'Q':  /* Query. Does the file/directory exist? */
			query(cp);
			continue;

		case 'S':  /* Special. Execute commands */
			dospecial(cp);
			continue;

#ifdef notdef
		/*
		 * These entries are reserved but not currently used.
		 * The intent is to allow remote hosts to have master copies.
		 * Currently, only the host rdist runs on can have masters.
		 */
		case 'X':  /* start a new list of files to exclude */
			except = bp = NULL;
		case 'x':  /* add name to list of files to exclude */
			if (*cp == '\0') {
				ack();
				continue;
			}
			if (*cp == '~') {
				if (exptilde(buf, cp) == NULL)
					continue;
				cp = buf;
			}
			if (bp == NULL)
				except = bp = expand(makeblock(NAME, cp), E_VARS);
			else
				bp->b_next = expand(makeblock(NAME, cp), E_VARS);
			while (bp->b_next != NULL)
				bp = bp->b_next;
			ack();
			continue;

		case 'I':  /* Install. Transfer file if out of date. */
			opts = 0;
			while (*cp >= '0' && *cp <= '7')
				opts = (opts << 3) | (*cp++ - '0');
			if (*cp++ != ' ') {
				error("server: options not delimited\n");
				return;
			}
			install(cp, opts);
			continue;

		case 'L':  /* Log. save message in log file */
			log(lfp, cp);
			continue;
#endif

		case '\1':
			nerrs++;
			continue;

		case '\2':
			return;

		default:
			error("server: unknown command '%s'\n", cp);
		case '\0':
			continue;
		}
	}
}
示例#2
0
SEXP Rscc_get_clustering_stats(const SEXP R_distances,
                               const SEXP R_clustering)
{
	Rscc_set_dist_functions();

	if (!isInteger(R_clustering)) {
		iRscc_error("`R_clustering` is not a valid clustering object.");
	}
	if (!isInteger(getAttrib(R_clustering, install("cluster_count")))) {
		iRscc_error("`R_clustering` is not a valid clustering object.");
	}
	if (!idist_check_distance_object(R_distances)) {
		iRscc_error("`R_distances` is not a valid distance object.");
	}

	const uint64_t num_data_points = (uint64_t) idist_num_data_points(R_distances);
	const uint64_t num_clusters = (uint64_t) asInteger(getAttrib(R_clustering, install("cluster_count")));

	if (((uint64_t) xlength(R_clustering)) != num_data_points) {
		iRscc_error("`R_distances` does not match `R_clustering`.");
	}
	if (num_clusters == 0) {
		iRscc_error("`R_clustering` is empty.");
	}

	scc_ErrorCode ec;
	scc_Clustering* clustering;
	if ((ec = scc_init_existing_clustering(num_data_points,
	                                       num_clusters,
	                                       INTEGER(R_clustering),
	                                       false,
	                                       &clustering)) != SCC_ER_OK) {
		iRscc_scc_error();
	}

	scc_ClusteringStats clust_stats;
	if ((ec = scc_get_clustering_stats(Rscc_get_distances_pointer(R_distances),
	                                   clustering,
	                                   &clust_stats)) != SCC_ER_OK) {
		scc_free_clustering(&clustering);
		iRscc_scc_error();
	}

	scc_free_clustering(&clustering);

	if (clust_stats.num_data_points > INT_MAX) iRscc_error("Too many data points.");
	if (clust_stats.num_assigned > INT_MAX) iRscc_error("Too many assigned data points.");
	if (clust_stats.num_populated_clusters > INT_MAX) iRscc_error("Too many clusters.");
	if (clust_stats.min_cluster_size > INT_MAX) iRscc_error("Too large clusters.");
	if (clust_stats.max_cluster_size > INT_MAX) iRscc_error("Too large clusters.");

	const SEXP R_clust_stats = PROTECT(allocVector(VECSXP, 13));
	SET_VECTOR_ELT(R_clust_stats, 0, ScalarInteger((int) clust_stats.num_data_points));
	SET_VECTOR_ELT(R_clust_stats, 1, ScalarInteger((int) clust_stats.num_assigned));
	SET_VECTOR_ELT(R_clust_stats, 2, ScalarInteger((int) clust_stats.num_populated_clusters));
	SET_VECTOR_ELT(R_clust_stats, 3, ScalarInteger((int) clust_stats.min_cluster_size));
	SET_VECTOR_ELT(R_clust_stats, 4, ScalarInteger((int) clust_stats.max_cluster_size));
	SET_VECTOR_ELT(R_clust_stats, 5, ScalarReal(clust_stats.avg_cluster_size));
	SET_VECTOR_ELT(R_clust_stats, 6, ScalarReal(clust_stats.sum_dists));
	SET_VECTOR_ELT(R_clust_stats, 7, ScalarReal(clust_stats.min_dist));
	SET_VECTOR_ELT(R_clust_stats, 8, ScalarReal(clust_stats.max_dist));
	SET_VECTOR_ELT(R_clust_stats, 9, ScalarReal(clust_stats.avg_min_dist));
	SET_VECTOR_ELT(R_clust_stats, 10, ScalarReal(clust_stats.avg_max_dist));
	SET_VECTOR_ELT(R_clust_stats, 11, ScalarReal(clust_stats.avg_dist_weighted));
	SET_VECTOR_ELT(R_clust_stats, 12, ScalarReal(clust_stats.avg_dist_unweighted));

	const SEXP R_clust_stats_names = PROTECT(allocVector(STRSXP, 13));
	SET_STRING_ELT(R_clust_stats_names, 0, mkChar("num_data_points"));
	SET_STRING_ELT(R_clust_stats_names, 1, mkChar("num_assigned"));
	SET_STRING_ELT(R_clust_stats_names, 2, mkChar("num_clusters"));
	SET_STRING_ELT(R_clust_stats_names, 3, mkChar("min_cluster_size"));
	SET_STRING_ELT(R_clust_stats_names, 4, mkChar("max_cluster_size"));
	SET_STRING_ELT(R_clust_stats_names, 5, mkChar("avg_cluster_size"));
	SET_STRING_ELT(R_clust_stats_names, 6, mkChar("sum_dists"));
	SET_STRING_ELT(R_clust_stats_names, 7, mkChar("min_dist"));
	SET_STRING_ELT(R_clust_stats_names, 8, mkChar("max_dist"));
	SET_STRING_ELT(R_clust_stats_names, 9, mkChar("avg_min_dist"));
	SET_STRING_ELT(R_clust_stats_names, 10, mkChar("avg_max_dist"));
	SET_STRING_ELT(R_clust_stats_names, 11, mkChar("avg_dist_weighted"));
	SET_STRING_ELT(R_clust_stats_names, 12, mkChar("avg_dist_unweighted"));
	setAttrib(R_clust_stats, R_NamesSymbol, R_clust_stats_names);

	UNPROTECT(2);
	return R_clust_stats;
}
示例#3
0
文件: main.c 项目: ArnoJuan/rxTools
__attribute__((section(".text.start"), noreturn)) void _start()
{
	static const TCHAR fontPath[] = _T("") SYS_PATH "/" FONT_NAME;
	void *fontBuf;
	UINT btr, br;
	int r;
	FIL f;

	// Enable TMIO IRQ
	*(volatile uint32_t *)0x10001000 = 0x00010000;

	preloadStringsA();

	
	if (!FSInit()) {
		DrawString(BOT_SCREEN, strings[STR_FAILED],
			BOT_SCREEN_WIDTH / 2, SCREEN_HEIGHT - FONT_HEIGHT, RED, BLACK);
		while (1);
	}

	
	set_loglevel(ll_info);
	log(ll_info, "Initializing rxTools...");
	

	setConsole();

	fontIsLoaded = 0;
	r = f_open(&f, fontPath, FA_READ);
	if (r == FR_OK) {
		btr = f_size(&f);
		fontBuf = __builtin_alloca(btr);
		r = f_read(&f, fontBuf, btr, &br);
		if (r == FR_OK)
			fontIsLoaded = 1;

		f_close(&f);
		fontaddr = fontBuf;
	}

	if (fontIsLoaded)
		preloadStringsU();
	else
		warn(L"Failed to load " FONT_NAME ": %d\n", r);

	if (getMpInfo() == MPINFO_KTR)
    {
        r = initN3DSKeys();
        if (r != FR_OK) {
            warn(L"Failed to load keys for N3DS\n"
            "  Code: %d\n"
            "  RxMode will not boot. Please\n"
            "  include key_0x16.bin and\n"
            "  key_0x1B.bin at the root of your\n"
            "  SD card.\n", r);
            InputWait();
            goto postinstall;
        }
    }


	install();
	postinstall:
	readCfg();

	log(ll_info, "Done...");

	r = loadStrings();
	if (r)
		warn(L"Failed to load strings: %d\n", r);

	drawTop();

	//Default boot check
	if (cfgs[CFG_DEFAULT].val.i && HID_STATE & BUTTON_L1)
		{
			if(cfgs[CFG_DEFAULT].val.i == 3) PastaMode();
			else rxMode(cfgs[CFG_DEFAULT].val.i - 1);
		}

	if (sysver < 7) {
		r = initKeyX();
		if (r != FR_OK)
			warn(L"Failed to load key X for slot 0x25\n"
				"  Code: %d\n"
				"  If your firmware version is less\n"
				"  than 7.X, some titles decryption\n"
				"  will fail, and some EmuNANDs\n"
				"  will not boot.\n", r);
	}

	if (warned) {
		warn(strings[STR_PRESS_BUTTON_ACTION],
			strings[STR_BUTTON_A], strings[STR_CONTINUE]);
		WaitForButton(BUTTON_A);
	}

	OpenAnimation();
	mainLoop();
}
示例#4
0
文件: R-exts.c 项目: Vladimir84/rcc
double feval(double x, SEXP f, SEXP rho)
{
    defineVar(install("x"), mkans(x), rho);
    return(REAL(eval(f, rho))[0]);
}
示例#5
0
void * EiC_yrealloc(char *file, int lineno, void *oldp, size_t nbytes)
{
    void *newp;
    int found = 0, d, bOld = 0, bno = 0; //maks

	if(nbytes <= 0 && oldp)
	{
		//maks: realloc definition
		EiC_yfree(file, lineno, oldp);
		return 0;
	}
    
    if(oldp != NULL) 
	{
		found =  xlookup(oldp);
		assertp(found < 0,STDMSG);
		bOld = 1; //maks
		bno = BNO(oldp);
    }

	if(GetGameMode())
	{
		unsigned long total = EiC_tot_memory + nbytes;
		if(total > gedMaxGameMem) //maks
		{
			//Don't alloc more then gedMaxGameMem
			EiC_error("Attempt to access %lu bytes.\n    If is correct, set the variable gedMaxGameMem=%lu or more\n    in an action before the allocation", nbytes, total);
			nbytes = 4;
		}
	}
	realAllocatedMem = nbytes;
    
    newp = realloc(oldp,nbytes);
    
    assertp(nbytes && newp == NULL,("line %d in file %s\n",lineno,file));
    
    if(bOld) //maks
	{
		d = nbytes - MTAB[bno].dbuf[found].nbytes;
		EiC_tot_memory -= MTAB[bno].dbuf[found].nbytes; //maks

		if(bno != BNO(newp)) 
		{
			
			int i;
			
			MTAB[bno].dbuf[found].p = NULL;
			MTAB[bno].dbuf[found].mark = freemark;
			i = install(file,lineno,newp,nbytes);
			/* retain creation time stamp */
			MTAB[BNO(newp)].dbuf[i].alloc_num
				= MTAB[bno].dbuf[found].alloc_num;
			
		} 
		else 
		{
			MTAB[bno].dbuf[found].p = newp;
			MTAB[bno].dbuf[found].nbytes = nbytes;
			MTAB[bno].dbuf[found].crt_file = file;
			MTAB[bno].dbuf[found].crt_lineno = lineno;

			EiC_tot_memory += nbytes; //maks
		}

		
    } 
	else
	{
		install(file,lineno,newp,nbytes);
	}
    

    return newp;
}
示例#6
0
static void deglobaliseState(SEXP state)
{
    int index = INTEGER(VECTOR_ELT(state, GSS_GLOBALINDEX))[0];
    SET_VECTOR_ELT(findVar(install(".GRID.STATE"), R_gridEvalEnv), 
		   index, R_NilValue);
}
示例#7
0
文件: Classes.c 项目: cran/party
SEXP party_init(void) {
    PL2_expectationSym = install("expectation");
    PL2_covarianceSym = install("covariance");
    PL2_linearstatisticSym = install("linearstatistic");
    PL2_expcovinfSym = install("expcovinf");
    PL2_expcovinfssSym = install("expcovinfss");
    PL2_sumweightsSym = install("sumweights");
    PL2_dimensionSym = install("dimension");
    PL2_MPinvSym = install("MPinv");
    PL2_rankSym = install("rank");
    PL2_svdmemSym = install("svdmem");
    PL2_methodSym = install("method");
    PL2_jobuSym = install("jobu");
    PL2_jobvSym = install("jobv");
    PL2_uSym = install("u");
    PL2_vSym = install("v");
    PL2_sSym = install("s");
    PL2_pSym = install("p"); 
    PL2_teststatSym = install("teststat");
    PL2_pvalueSym = install("pvalue");
    PL2_tolSym = install("tol");
    PL2_maxptsSym = install("maxpts");
    PL2_absepsSym = install("abseps");
    PL2_relepsSym = install("releps");
    PL2_minsplitSym = install("minsplit");
    PL2_minprobSym = install("minprob");
    PL2_minbucketSym = install("minbucket");
    PL2_variablesSym = install("variables"); 
    PL2_transformationsSym = install("transformations"); 
    PL2_is_nominalSym = install("is_nominal"); 
    PL2_is_ordinalSym = install("is_ordinal"); 
    PL2_is_censoredSym = install("is_censored"); 
    PL2_orderingSym = install("ordering"); 
    PL2_levelsSym = install("levels"); 
    PL2_scoresSym = install("scores"); 
    PL2_has_missingsSym = install("has_missings"); 
    PL2_whichNASym = install("whichNA"); 
    PL2_test_trafoSym = install("test_trafo"); 
    PL2_predict_trafoSym = install("predict_trafo"); 
    PL2_nobsSym = install("nobs"); 
    PL2_ninputsSym = install("ninputs"); 
    PL2_linexpcov2sampleSym = install("linexpcov2sample"); 
    PL2_weightsSym = install("weights"); 
    PL2_varmemorySym = install("varmemory"); 
    PL2_splitstatisticsSym = install("splitstatistics");
    PL2_savesplitstatsSym = install("savesplitstats");
    PL2_responsesSym = install("responses"); 
    PL2_inputsSym = install("inputs"); 
    PL2_testtypeSym = install("testtype"); 
    PL2_nresampleSym = install("nresample"); 
    PL2_varctrlSym = install("varctrl"); 
    PL2_splitctrlSym = install("splitctrl"); 
    PL2_gtctrlSym = install("gtctrl"); 
    PL2_mincriterionSym = install("mincriterion"); 
    PL2_maxsurrogateSym = install("maxsurrogate"); 
    PL2_randomsplitsSym = install("randomsplits"); 
    PL2_mtrySym = install("mtry"); 
    PL2_dontuseSym = install("dontuse"); 
    PL2_dontusetmpSym = install("dontusetmp"); 
    PL2_stumpSym = install("stump"); 
    PL2_maxdepthSym = install("maxdepth"); 
    PL2_tgctrlSym = install("tgctrl"); 
    PL2_ntreeSym = install("ntree"),
    PL2_replaceSym = install("replace"),
    PL2_fractionSym = install("fraction");
    PL2_traceSym = install("trace");
    PL2_ensembleSym = install("ensemble");
    PL2_whereSym = install("where");
    PL2_remove_weightsSym = install("remove_weights");
    return(R_NilValue);
}
示例#8
0
文件: cursor.c 项目: cran/RBerkeley
/* {{{ rberkeley_dbcursor_get */
SEXP rberkeley_dbcursor_get (SEXP _dbc,
                             SEXP _key,
                             SEXP _data,
                             SEXP _flags,
                             SEXP _n /* non-API flag */)
{
  DBC *dbc;
  DBT key, data;
  u_int32_t flags;
  int i, n, ret, P=0;

  flags = (u_int32_t)INTEGER(_flags)[0];
  n = (INTEGER(_n)[0] < 0) ? 100 : INTEGER(_n)[0]; /* this should be _all_ data */

  dbc = R_ExternalPtrAddr(_dbc);
  if(R_ExternalPtrTag(_dbc) != install("DBC") || dbc == NULL)
    error("invalid 'dbc' handle");

  memset(&key, 0, sizeof(DBT));
  memset(&data, 0, sizeof(DBT));

  SEXP Keys, Data, results;
  PROTECT(Keys = allocVector(VECSXP, n)); P++;
  PROTECT(Data = allocVector(VECSXP, n)); P++;
  PROTECT(results = allocVector(VECSXP, n)); P++;

  /*
    Two scenarios for DBcursor->get calls:
    (1) key and data are SPECIFIED <OR> key is SPECIFIED, data is EMPTY
    (2) key and data are EMPTY

    We must handle these seperately in order
    to return a sensible result
  */
  if( (!isNull(_key) &&
      !isNull(_data)) || !isNull(_key)  ) {
    /* need to handle cases where multiple results
       can be returned. Possibly given that flag
       we can instead use the last if-else branch */
    key.data = (unsigned char *)RAW(_key);
    key.size = length(_key);

    if(!isNull(_data)) {
      data.data = (unsigned char *)RAW(_data);
      data.size = length(_data);
    }

    ret = dbc->get(dbc, &key, &data, flags);
    if(ret == 0) {
      SEXP KeyData;
      PROTECT(KeyData = allocVector(VECSXP, 2));P++;

      SEXP rawkey;
      PROTECT(rawkey = allocVector(RAWSXP, key.size));
      memcpy(RAW(rawkey), key.data, key.size);
      SET_VECTOR_ELT(KeyData, 0, rawkey);
      UNPROTECT(1);

      SEXP rawdata;
      PROTECT(rawdata = allocVector(RAWSXP, data.size));
      memcpy(RAW(rawdata), data.data, data.size);
      SET_VECTOR_ELT(KeyData, 1, rawdata);
      UNPROTECT(1);

      SEXP KeyDataNames;
      PROTECT(KeyDataNames = allocVector(STRSXP,2)); P++;
      SET_STRING_ELT(KeyDataNames, 0, mkChar("key"));
      SET_STRING_ELT(KeyDataNames, 1, mkChar("data"));
      setAttrib(KeyData, R_NamesSymbol, KeyDataNames);
      SET_VECTOR_ELT(results, 0, KeyData);
      PROTECT(results = lengthgets(results, 1)); P++;
    }
  } else
  if(isNull(_key) && isNull(_data)) {
    for(i = 0; i < n; i++) {
      ret = dbc->get(dbc, &key, &data, flags);
      if(ret == 0) {
        SEXP KeyData;
        PROTECT(KeyData = allocVector(VECSXP, 2));

        SEXP rawkey;
        PROTECT(rawkey = allocVector(RAWSXP, key.size));
        memcpy(RAW(rawkey), key.data, key.size);
        SET_VECTOR_ELT(KeyData, 0, rawkey);

        SEXP rawdata;
        PROTECT(rawdata = allocVector(RAWSXP, data.size));
        memcpy(RAW(rawdata), data.data, data.size);
        SET_VECTOR_ELT(KeyData, 1, rawdata);

        SEXP KeyDataNames;
        PROTECT(KeyDataNames = allocVector(STRSXP,2));
        SET_STRING_ELT(KeyDataNames, 0, mkChar("key"));
        SET_STRING_ELT(KeyDataNames, 1, mkChar("data"));
        setAttrib(KeyData, R_NamesSymbol, KeyDataNames);
        SET_VECTOR_ELT(results, i, KeyData);
        UNPROTECT(4); /* KeyDataNames, rawdata, rawkey, KeyData */
      } else { /* end of data */
        if(i == 0) { /* no results */
          UNPROTECT(P);
          return ScalarInteger(ret);
        }
        /* truncate the keys and data to the i-size found */
        PROTECT(results = lengthgets(results, i)); P++;
        break;
      }
    }
  }
  UNPROTECT(P);
  return results;
}
示例#9
0
SEXP attribute_hidden do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP tlist = R_NilValue;
    int intern = 0;

    checkArity(op, args);
    if (!isValidStringF(CAR(args)))
	error(_("non-empty character argument expected"));
    intern = asLogical(CADR(args));
    if (intern == NA_INTEGER)
	error(_("'intern' must be logical and not NA"));
    if (intern) { /* intern = TRUE */
	FILE *fp;
	char *x = "r", buf[INTERN_BUFSIZE];
	const char *cmd;
	int i, j, res;
	SEXP tchar, rval;

	PROTECT(tlist);
	cmd = translateChar(STRING_ELT(CAR(args), 0));
	errno = 0; /* precaution */
	if(!(fp = R_popen(cmd, x)))
	    error(_("cannot popen '%s', probable reason '%s'"),
		  cmd, strerror(errno));
	for (i = 0; fgets(buf, INTERN_BUFSIZE, fp); i++) {
	    size_t read = strlen(buf);
	    if(read >= INTERN_BUFSIZE - 1)
		warning(_("line %d may be truncated in call to system(, intern = TRUE)"), i + 1);
	    if (read > 0 && buf[read-1] == '\n')
		buf[read - 1] = '\0'; /* chop final CR */
	    tchar = mkChar(buf);
	    UNPROTECT(1);
	    PROTECT(tlist = CONS(tchar, tlist));
	}
	res = pclose(fp);
#ifdef HAVE_SYS_WAIT_H
	if (WIFEXITED(res)) res = WEXITSTATUS(res);
	else res = 0;
#else
	/* assume that this is shifted if a multiple of 256 */
	if ((res % 256) == 0) res = res/256;
#endif
	if ((res & 0xff)  == 127) {/* 127, aka -1 */
	    if (errno)
		error(_("error in running command: '%s'"), strerror(errno));
	    else
		error(_("error in running command"));
	} else if (res) {
	    if (errno)
		warningcall(R_NilValue, 
			    _("running command '%s' had status %d and error message '%s'"), 
			    cmd, res, 
			    strerror(errno));
	    else 
		warningcall(R_NilValue, 
			    _("running command '%s' had status %d"), 
			    cmd, res);
	}
	
	rval = PROTECT(allocVector(STRSXP, i));
	for (j = (i - 1); j >= 0; j--) {
	    SET_STRING_ELT(rval, j, CAR(tlist));
	    tlist = CDR(tlist);
	}
	if(res) {
	    SEXP lsym = install("status");
	    setAttrib(rval, lsym, ScalarInteger(res));
	    if(errno) {
		lsym = install("errmsg");
		setAttrib(rval, lsym, mkString(strerror(errno)));
	    }
	}
	UNPROTECT(2);
	return rval;
    }
    else { /* intern =  FALSE */
#ifdef HAVE_AQUA
	R_Busy(1);
#endif
	tlist = PROTECT(allocVector(INTSXP, 1));
	fflush(stdout);
	INTEGER(tlist)[0] = R_system(translateChar(STRING_ELT(CAR(args), 0)));
#ifdef HAVE_AQUA
	R_Busy(0);
#endif
	UNPROTECT(1);
	R_Visible = 0;
	return tlist;
    }
}
示例#10
0
文件: sys-std.c 项目: lovmoy/r-source
static void initialize_rlcompletion(void)
{
    if(rcompgen_active >= 0) return;

    /* Find if package utils is around */
    if(rcompgen_active < 0) {
	char *p = getenv("R_COMPLETION");
	if(p && streql(p, "FALSE")) {
	    rcompgen_active = 0;
	    return;
	}
	/* First check if namespace is loaded */
	if(findVarInFrame(R_NamespaceRegistry, install("utils"))
	   != R_UnboundValue) rcompgen_active = 1;
	else { /* Then try to load it */
	    SEXP cmdSexp, cmdexpr;
	    ParseStatus status;
	    int i;
	    char *p = "try(loadNamespace('rcompgen'), silent=TRUE)";

	    PROTECT(cmdSexp = mkString(p));
	    cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
	    if(status == PARSE_OK) {
		for(i = 0; i < length(cmdexpr); i++)
		    eval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv);
	    }
	    UNPROTECT(2);
	    if(findVarInFrame(R_NamespaceRegistry, install("utils"))
	       != R_UnboundValue) rcompgen_active = 1;
	    else {
		rcompgen_active = 0;
		return;
	    }
	}
    }

    rcompgen_rho = R_FindNamespace(mkString("utils"));

    RComp_assignBufferSym  = install(".assignLinebuffer");
    RComp_assignStartSym   = install(".assignStart");
    RComp_assignEndSym     = install(".assignEnd");
    RComp_assignTokenSym   = install(".assignToken");
    RComp_completeTokenSym = install(".completeToken");
    RComp_getFileCompSym   = install(".getFileComp");
    RComp_retrieveCompsSym = install(".retrieveCompletions");

    /* Tell the completer that we want a crack first. */
    rl_attempted_completion_function = R_custom_completion;

    /* Disable sorting of possible completions; only readline >= 6 */
#if RL_READLINE_VERSION >= 0x0600
    /* if (rl_readline_version >= 0x0600) */
    rl_sort_completion_matches = 0;
#endif

    /* token boundaries.  Includes *,+ etc, but not $,@ because those
       are easier to handle at the R level if the whole thing is
       available.  However, this breaks filename completion if partial
       filenames contain things like $, % etc.  Might be possible to
       associate a M-/ override like bash does.  One compromise is that
       we exclude / from the breakers because that is frequently found
       in filenames even though it is also an operator.  This can be
       handled in R code (although it shouldn't be necessary if users
       surround operators with spaces, as they should).  */

    /* FIXME: quotes currently lead to filename completion without any
       further ado.  This is not necessarily the best we can do, since
       quotes after a [, $, [[, etc should be treated differently.  I'm
       not testing this now, but this should be doable by removing quote
       characters from the strings below and handle it with other things
       in 'specialCompletions()' in R.  The problem with that approach
       is that file name completion will probably have to be done
       manually in R, which is not trivial.  One way to go might be to
       forego file name completion altogether when TAB completing, and
       associate M-/ or something to filename completion (a startup
       message might say so, to remind users)

       All that might not be worth the pain though (vector names would
       be practically impossible, to begin with) */


    return;
}
示例#11
0
SEXP lapack_qr(SEXP Xin, SEXP tl)
{
    SEXP ans, Givens, Gcpy, nms, pivot, qraux, X;
    int i, n, nGivens = 0, p, trsz, *Xdims, rank;
    double rcond = 0., tol = asReal(tl), *work;

    if (!(isReal(Xin) & isMatrix(Xin)))
	error(_("X must be a real (numeric) matrix"));
    if (tol < 0.) error(_("tol, given as %g, must be non-negative"), tol);
    if (tol > 1.) error(_("tol, given as %g, must be <= 1"), tol);
    ans = PROTECT(allocVector(VECSXP,5));
    SET_VECTOR_ELT(ans, 0, X = duplicate(Xin));
    Xdims = INTEGER(coerceVector(getAttrib(X, R_DimSymbol), INTSXP));
    n = Xdims[0]; p = Xdims[1];
    SET_VECTOR_ELT(ans, 2, qraux = allocVector(REALSXP, (n < p) ? n : p));
    SET_VECTOR_ELT(ans, 3, pivot = allocVector(INTSXP, p));
    for (i = 0; i < p; i++) INTEGER(pivot)[i] = i + 1;
    trsz = (n < p) ? n : p;	/* size of triangular part of decomposition */
    rank = trsz;
    Givens = PROTECT(allocVector(VECSXP, rank - 1));
    setAttrib(ans, R_NamesSymbol, nms = allocVector(STRSXP, 5));
    SET_STRING_ELT(nms, 0, mkChar("qr"));
    SET_STRING_ELT(nms, 1, mkChar("rank"));
    SET_STRING_ELT(nms, 2, mkChar("qraux"));
    SET_STRING_ELT(nms, 3, mkChar("pivot"));
    SET_STRING_ELT(nms, 4, mkChar("Givens"));
    if (n > 0 && p > 0) {
	int  info, *iwork, lwork;
	double *xpt = REAL(X), tmp;

	lwork = -1;
	F77_CALL(dgeqrf)(&n, &p, xpt, &n, REAL(qraux), &tmp, &lwork, &info);
	if (info)
	    error(_("First call to dgeqrf returned error code %d"), info);
	lwork = (int) tmp;
	work = (double *) R_alloc((lwork < 3*trsz) ? 3*trsz : lwork,
				  sizeof(double));
	F77_CALL(dgeqrf)(&n, &p, xpt, &n, REAL(qraux), work, &lwork, &info);
	if (info)
	    error(_("Second call to dgeqrf returned error code %d"), info);
	iwork = (int *) R_alloc(trsz, sizeof(int));
	F77_CALL(dtrcon)("1", "U", "N", &rank, xpt, &n, &rcond,
			 work, iwork, &info);
	if (info)
	    error(_("Lapack routine dtrcon returned error code %d"), info);
	while (rcond < tol) {	/* check diagonal elements */
	    double minabs = (xpt[0] < 0.) ? -xpt[0]: xpt[0];
	    int jmin = 0;
	    for (i = 1; i < rank; i++) {
		double el = xpt[i*(n+1)];
		el = (el < 0.) ? -el: el;
		if (el < minabs) {
		    jmin = i;
		    minabs = el;
		}
	    }
	    if (jmin < (rank - 1)) {
		SET_VECTOR_ELT(Givens, nGivens, getGivens(xpt, n, jmin, rank));
		nGivens++;
	    }
	    rank--;
	    F77_CALL(dtrcon)("1", "U", "N", &rank, xpt, &n, &rcond,
			     work, iwork, &info);
	    if (info)
		error(_("Lapack routine dtrcon returned error code %d"), info);
	}
    }
    SET_VECTOR_ELT(ans, 4, Gcpy = allocVector(VECSXP, nGivens));
    for (i = 0; i < nGivens; i++)
	SET_VECTOR_ELT(Gcpy, i, VECTOR_ELT(Givens, i));
    SET_VECTOR_ELT(ans, 1, ScalarInteger(rank));
    setAttrib(ans, install("useLAPACK"), ScalarLogical(1));
    setAttrib(ans, install("rcond"), ScalarReal(rcond));
    UNPROTECT(2);
    return ans;
}
示例#12
0
文件: leadingNA.c 项目: Glanda/xts
SEXP na_omit_xts (SEXP x)
{
  SEXP na_index, not_na_index, col_index, result;

  int i, j, ij, nr, nc; 
  int not_NA, NA;

  nr = nrows(x);
  nc = ncols(x);
  not_NA = nr;
  
  int *int_x=NULL, *int_na_index=NULL, *int_not_na_index=NULL;
  double *real_x=NULL;

  switch(TYPEOF(x)) {
    case LGLSXP:
      for(i=0; i<nr; i++) {
        for(j=0; j<nc; j++) {
          ij = i + j*nr;
          if(LOGICAL(x)[ij] == NA_LOGICAL) {
            not_NA--;
            break;
          }   
        }   
      }
      break;
    case INTSXP:
      int_x = INTEGER(x);
      for(i=0; i<nr; i++) {
        for(j=0; j<nc; j++) {
          ij = i + j*nr;
          if(int_x[ij] == NA_INTEGER) {
            not_NA--;
            break;
          }   
        }   
      }
      break;
    case REALSXP:
      real_x = REAL(x);
      for(i=0; i<nr; i++) {
        for(j=0; j<nc; j++) {
          ij = i + j*nr;
          if(ISNA(real_x[ij]) || ISNAN(real_x[ij])) {
            not_NA--;
            break;
          }   
        }   
      }
      break;
    default:
      error("unsupported type");
      break;
  }
  
  if(not_NA==0) { /* all NAs */
    return(allocVector(TYPEOF(x),0));    
  }

  if(not_NA==0 || not_NA==nr)
    return(x);

  PROTECT(not_na_index = allocVector(INTSXP, not_NA));
  PROTECT(na_index = allocVector(INTSXP, nr-not_NA));

  /* pointers for efficiency as INTEGER in package code is a function call*/
  int_not_na_index = INTEGER(not_na_index);
  int_na_index = INTEGER(na_index);

  not_NA = NA = 0;
  switch(TYPEOF(x)) {
    case LGLSXP:
      for(i=0; i<nr; i++) {
        for(j=0; j<nc; j++) {
          ij = i + j*nr;
          if(LOGICAL(x)[ij] == NA_LOGICAL) {
            int_na_index[NA] = i+1;
            NA++;
            break;
          }
          if(j==(nc-1)) {
            /* make it to end of column, OK*/
            int_not_na_index[not_NA] = i+1;
            not_NA++;
          }   
        }   
      }
      break;
    case INTSXP:
      for(i=0; i<nr; i++) {
        for(j=0; j<nc; j++) {
          ij = i + j*nr;
          if(int_x[ij] == NA_INTEGER) {
            int_na_index[NA] = i+1;
            NA++;
            break;
          }
          if(j==(nc-1)) {
            /* make it to end of column, OK*/
            int_not_na_index[not_NA] = i+1;
            not_NA++;
          }   
        }   
      }
      break;
    case REALSXP:
      for(i=0; i<nr; i++) {
        for(j=0; j<nc; j++) {
          ij = i + j*nr;
          if(ISNA(real_x[ij]) || ISNAN(real_x[ij])) {
            int_na_index[NA] = i+1;
            NA++;
            break;
          }
          if(j==(nc-1)) {
            /* make it to end of column, OK*/
            int_not_na_index[not_NA] = i+1;
            not_NA++;
          }   
        }   
      }
      break;
    default:
      error("unsupported type");
      break;
  }

  PROTECT(col_index = allocVector(INTSXP, nc));
  for(i=0; i<nc; i++)
    INTEGER(col_index)[i] = i+1;

  SEXP drop;
  drop = allocVector(LGLSXP, 1);
  LOGICAL(drop)[0] = 0;

  PROTECT(result = do_subset_xts(x, not_na_index, col_index, drop));

  SEXP class;
  PROTECT(class = allocVector(STRSXP, 1));
  SET_STRING_ELT(class, 0, mkChar("omit"));
  setAttrib(na_index, R_ClassSymbol, class);
  UNPROTECT(1);

  setAttrib(result, install("na.action"), na_index);
  UNPROTECT(4);

  return(result);
}
示例#13
0
文件: init.c 项目: rforge/blme
void R_init_blme(DllInfo *dll)
{
    R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
    R_useDynamicSymbols(dll, FALSE);


    M_R_cholmod_start(&cholmodCommon);
    cholmodCommon.final_ll = 1;	    /* LL' form of simplicial factorization */

    lme4_ASym = install("A");
    lme4_CmSym = install("Cm");
    lme4_CxSym = install("Cx");
    lme4_DimSym = install("Dim");
    lme4_GpSym = install("Gp");
    lme4_LSym = install("L");
    lme4_RXSym = install("RX");
    lme4_RZXSym = install("RZX");
    lme4_STSym = install("ST");
    lme4_VSym = install("V");
    lme4_XSym = install("X");
    lme4_XstSym = install("Xst");
    lme4_ZtSym = install("Zt");
    lme4_devianceSym = install("deviance");
    lme4_dimsSym = install("dims");
    lme4_envSym = install("env");
    lme4_etaSym = install("eta");
    lme4_fixefSym = install("fixef");
    lme4_flistSym = install("flist");
    lme4_ghwSym = install("ghw");
    lme4_ghxSym = install("ghx");
    lme4_gradientSym = install("gradient");
    lme4_iSym = install("i");
    lme4_ncSym = install("nc");
    lme4_nlmodelSym = install("nlmodel");
    lme4_muEtaSym = install("muEta");
    lme4_muSym = install("mu");
    lme4_offsetSym = install("offset");
    lme4_pSym = install("p");
    lme4_permSym = install("perm");
    lme4_pWtSym = install("pWt");
    lme4_ranefSym = install("ranef");
    lme4_residSym = install("resid");
    lme4_sigmaSym = install("sigma");
    lme4_sqrtrWtSym = install("sqrtrWt");
    lme4_sqrtXWtSym = install("sqrtXWt");
    lme4_uSym = install("u");
    lme4_varSym = install("var");
    lme4_xSym = install("x");
    lme4_ySym = install("y");
    blme_covariancePriorSym           = install("cov.prior");
    blme_unmodeledCoefficientPriorSym = install("fixef.prior");
    blme_commonScalePriorSym          = install("var.prior");
    
    blme_prior_typeSym            = install("type");
    blme_prior_familiesSym        = install("families");
    blme_prior_scalesSym          = install("scales");
    blme_prior_hyperparametersSym = install("hyperparameters");
}
示例#14
0
/**
 * @brief Services::reinstall
 * @param serviceName
 *
 * Reinstall Windows Service
 * equivalent to remove() followed by install()
 */
void Services::reinstall(QString serviceName)
{
    remove(serviceName);
    install(serviceName);
}
示例#15
0
/**
 * Class implementing the proxy auto-configuration (PAC) JavaScript api.
 *
 * Based on qt-examples: https://gitorious.org/qt-examples/qt-examples/blobs/master/pac-files
 */
ProxyAutoConfig::ProxyAutoConfig(QObject* parent)
    : QObject(parent)
    , m_engine(new QScriptEngine(this))
{
    install();
}
示例#16
0
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();
}
示例#17
0
SEXP rgeos_binary_STRtree_query(SEXP env, SEXP obj1, SEXP obj2) {

    GEOSGeom *bbs2;
    int nobj1, nobj2, i, j, pc=0, isPts=FALSE;
    GEOSGeom GC, GCpts=NULL, bb;
    SEXP pl, bblist;
    GEOSSTRtree *str;
    int *icard, *ids, *oids;
    char classbuf1[BUFSIZ], classbuf2[BUFSIZ];
    GEOSGeom (*rgeos_xx2MP)(SEXP, SEXP);

    strcpy(classbuf1, CHAR(STRING_ELT(GET_CLASS(VECTOR_ELT(obj1, 0)), 0)));
    if (!strncmp(classbuf1, "Polygons", 8)) 
        rgeos_xx2MP = rgeos_Polygons2MP;
    else if (!strncmp(classbuf1, "Lines", 5)) 
        rgeos_xx2MP = rgeos_Lines2MP;
    else
        error("rgeos_binary_STRtree_query: object class %s unknown", classbuf1);

    GEOSContextHandle_t GEOShandle = getContextHandle(env);

    str = (GEOSSTRtree *) GEOSSTRtree_create_r(GEOShandle, (size_t) 10);

    nobj1 = length(obj1);

    SEXP cl2 = GET_CLASS(obj2);
    if (cl2 == R_NilValue) strcpy(classbuf2, "\0");
    else strcpy(classbuf2, CHAR(STRING_ELT(cl2, 0)));
    if ( !strcmp( classbuf2, "SpatialPoints") || 
        !strcmp(classbuf2, "SpatialPointsDataFrame")) {
        isPts = TRUE;
        SEXP crds = GET_SLOT(obj2, install("coords")); 
        SEXP dim = getAttrib(crds, install("dim")); 
        nobj2 = INTEGER_POINTER(dim)[0];
    } else {
        nobj2 = length(obj2);
    }
    bbs2 = (GEOSGeom *) R_alloc((size_t) nobj2, sizeof(GEOSGeom));
    ids = (int *) R_alloc((size_t) nobj1, sizeof(int));

    UD.ids = (int *) R_alloc((size_t) nobj1, sizeof(int));
    oids = (int *) R_alloc((size_t) nobj1, sizeof(int));

    for (i=0; i<nobj1; i++) {
        ids[i] = i;
        pl = VECTOR_ELT(obj1, i);
        GC = rgeos_xx2MP(env, pl);
        if (GC == NULL) {
            error("rgeos_binary_STRtree_query: MP GC[%d] not created", i);
        }
        if ((bb = GEOSEnvelope_r(GEOShandle, GC)) == NULL) {
            error("rgeos_binary_STRtree_query: envelope [%d] not created", i);
        }
        GEOSGeom_destroy_r(GEOShandle, GC);
        GEOSSTRtree_insert_r(GEOShandle, str, bb, &(ids[i]));
    }

    if (isPts) {
        GCpts = rgeos_SpatialPoints2geospoint(env, obj2);
    } else {
        strcpy(classbuf2, CHAR(STRING_ELT(GET_CLASS(VECTOR_ELT(obj2, 0)), 0)));
        if (!strncmp(classbuf2, "Polygons", 8)) 
            rgeos_xx2MP = rgeos_Polygons2MP;
        else if (!strncmp(classbuf2, "Lines", 5)) 
            rgeos_xx2MP = rgeos_Lines2MP;
        else
            error("rgeos_binary_STRtree_query: object class %s unknown",
                classbuf2);
    }

    for (i=0; i<nobj2; i++) {
        if (isPts) {
            GC = (GEOSGeom) GEOSGetGeometryN_r(GEOShandle, GCpts, i);
        } else {
            pl = VECTOR_ELT(obj2, i);
            GC = rgeos_xx2MP(env, pl);
        }
        if (GC == NULL) {
            error("rgeos_binary_STRtree_query: GC[%d] not created", i);
        }
        if ((bb = GEOSEnvelope_r(GEOShandle, GC)) == NULL) {
            error("rgeos_binary_STRtree_query: envelope [%d] not created", i);
        }
        GEOSGeom_destroy_r(GEOShandle, GC);
// Rprintf("i: %d, bb %s\n", i, GEOSGeomType_r(GEOShandle, bb));
        bbs2[i] = bb;
    }
// 110904 EJP
    icard = (int *) R_alloc((size_t) nobj2, sizeof(int));
    PROTECT(bblist = NEW_LIST(nobj2)); pc++;

    for (i=0; i<nobj2; i++) {
        UD.count = 0;
        GEOSSTRtree_query_r(GEOShandle, str, bbs2[i],
            (GEOSQueryCallback) cb, &UD);

        icard[i] = UD.count;

        if (icard[i] > 0) {
            SET_VECTOR_ELT(bblist, i, NEW_INTEGER(icard[i]));

            for (j=0; j<UD.count; j++) {
                oids[j] = UD.ids[j] + R_OFFSET;
            }
            R_isort(oids, UD.count);
            for (j=0; j<UD.count; j++) {
                INTEGER_POINTER(VECTOR_ELT(bblist, i))[j] = oids[j];
            }
        }
    }

    GEOSSTRtree_destroy_r(GEOShandle, str);
    for (i=0; i<nobj2; i++) {
        GEOSGeom_destroy_r(GEOShandle, bbs2[i]);
    }

    UNPROTECT(pc);
    return(bblist);
}
示例#18
0
SEXP GillespieDirectCR(SEXP pre, SEXP post, SEXP h, SEXP M, SEXP T, SEXP delta,
		       SEXP runs, SEXP place, SEXP transition, SEXP rho)
{
  int k;

#ifdef RB_TIME
  clock_t c0, c1;
  c0 = clock();
#endif

  // Get dimensions of pre
  int *piTmp = INTEGER(getAttrib(pre, R_DimSymbol));
  int iTransitions = piTmp[0], iPlaces = piTmp[1];

  int *piPre = INTEGER(pre), *piPost = INTEGER(post);

  SEXP sexpTmp;

  int iTransition, iPlace, iTransitionPtr, iPlacePtr,
    iTransition2, iTransitionPtr2;

  // Find out which elements of h are doubles and which functions
  SEXP sexpFunction;
  PROTECT(sexpFunction = allocVector(VECSXP, iTransitions));
  double *pdH = (double *) R_alloc(iTransitions, sizeof(double));
  DL_FUNC *pCFunction = (DL_FUNC *) R_alloc(iTransitions, sizeof(DL_FUNC *));
  int *piHzType = (int *) R_alloc(iTransitions, sizeof(int));
  for (iTransition = 0; iTransition < iTransitions; iTransition++) {
    if (inherits(sexpTmp = VECTOR_ELT(h, iTransition), "NativeSymbol")) {
      pCFunction[iTransition] = (void *) R_ExternalPtrAddr(sexpTmp);
      piHzType[iTransition] = HZ_CFUNCTION;    
    } else if (isNumeric(sexpTmp)){
      pdH[iTransition] = REAL(sexpTmp)[0];
      piHzType[iTransition] = HZ_DOUBLE;
    } else  if (isFunction(sexpTmp)) {
      SET_VECTOR_ELT(sexpFunction, iTransition, lang1(sexpTmp));
      piHzType[iTransition] = HZ_RFUNCTION;
    } else {
      error("Unrecongnized transition function type\n");
    }
  }

  // Setup Matrix S
  int *piS = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));

  // Position of non zero cells in pre per transition
  int *piPreNZxRow = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));

  // Totals of non zero cells in pre per transition
  int *piPreNZxRowTot = (int *) R_alloc(iTransitions, sizeof(int));

  // Position of non zero cells in S per transition
  int *piSNZxRow = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));

  // Totals of non zero cells in S per transition
  int *piSNZxRowTot = (int *) R_alloc(iTransitions, sizeof(int));

  for (iTransition = 0; iTransition < iTransitions; iTransition++) {
    int iPreNZxRow_col = 0;
    int iSNZxRow_col = 0;
    for (iPlace = 0; iPlace < iPlaces; iPlace++) {
      if (piPre[iTransition + iTransitions * iPlace]) {
	piPreNZxRow[iTransition + iTransitions * iPreNZxRow_col++] = iPlace;
      }
      if ((piS[iTransition + iTransitions * iPlace] = 
	   piPost[iTransition + iTransitions * iPlace] - piPre[iTransition + iTransitions * iPlace])) {
	piSNZxRow[iTransition + iTransitions * iSNZxRow_col++] = iPlace;
      }
    }
    piPreNZxRowTot[iTransition] = iPreNZxRow_col;
    piSNZxRowTot[iTransition] = iSNZxRow_col;
  }

  // Position of non zero cells in pre per place
  int *piPreNZxCol = (int *) R_alloc(iTransitions * iPlaces, sizeof(int));

  // Totals of non zero cells in pre per place
  int *piPreNZxColTot = (int *) R_alloc(iPlaces, sizeof(int));

  for (iPlace = 0; iPlace < iPlaces; iPlace++) {
    int iPreNZxCol_row = 0;
    for (iTransition = 0; iTransition < iTransitions; iTransition++) {
      if (piPre[iTransition + iTransitions * iPlace]) {
	piPreNZxCol[iPreNZxCol_row++ + iTransitions * iPlace] = iTransition;
      }
    }
    piPreNZxColTot[iPlace] = iPreNZxCol_row;
  }

  // Hazards that need to be recalculated if a given transition has happened
  int *piHazardsToModxRow = (int *) R_alloc((iTransitions + 1) * iTransitions, sizeof(int));

  // Totals of hazards to recalculate for each transition that has happened
  int *piHazardsToModxRowTot = (int *) R_alloc(iTransitions + 1, sizeof(int));
  
  for(iTransition = 0; iTransition < iTransitions; iTransition++) {
    int iHazardToCompTot = 0;
    for(iPlace = 0; iPlace < iPlaces; iPlace++) {
      if (piS[iTransition + iTransitions * iPlace]) {
	// Identify the transitions that need the hazards recalculated
	for(iTransitionPtr2 = 0; iTransitionPtr2 < piPreNZxColTot[iPlace]; iTransitionPtr2++) {
	  iTransition2 = piPreNZxCol[iTransitionPtr2 + iTransitions * iPlace];
	  int iAddThis = TRUE;
	  for (k = 0; k < iHazardToCompTot; k++) {
	    if(piHazardsToModxRow[iTransition + (iTransitions + 1) * k] == iTransition2) {
	      iAddThis = FALSE;
	      break;
	    }
	  }	    
	  if (iAddThis)
	    piHazardsToModxRow[iTransition + (iTransitions + 1) * iHazardToCompTot++] = iTransition2;
	}
      }
    }
    piHazardsToModxRowTot[iTransition] = iHazardToCompTot;
  }
  // For the initial calculation of all hazards...
  for(iTransition = 0; iTransition < iTransitions; iTransition++) {
    piHazardsToModxRow[iTransitions + (iTransitions + 1) * iTransition] = iTransition;
  }
  piHazardsToModxRowTot[iTransitions] = iTransitions;

  SEXP sexpCrntMarking;
  PROTECT(sexpCrntMarking = allocVector(REALSXP, iPlaces));
  double *pdCrntMarking = REAL(sexpCrntMarking);

  double dDelta = *REAL(delta);
  int iTotalSteps, iSectionSteps;
  double dT = 0;
  void *pCManage_time = 0;
  SEXP sexpRManage_time = 0;
  if (inherits(T, "NativeSymbol")) {
    pCManage_time = (void *) R_ExternalPtrAddr(T);
    dT = ((double(*)(double, double *)) pCManage_time)(-1, pdCrntMarking);
  } else if (isNumeric(T)){
    dT = *REAL(T);
  } else  if (isFunction(T)) {
    PROTECT(sexpRManage_time = lang1(T));

    defineVar(install("y"), sexpCrntMarking, rho);
    PROTECT(sexpTmp = allocVector(REALSXP, 1));
    *REAL(sexpTmp) = -1;
    defineVar(install("StartTime"), sexpTmp, rho);
    UNPROTECT_PTR(sexpTmp);
    dT = *REAL(VECTOR_ELT(eval(sexpRManage_time, rho),0));
  } else {
    error("Unrecognized time function type\n");
  }
  
  iTotalSteps = iSectionSteps = (int)(dT / dDelta) + 1;

  int iRun, iRuns = *INTEGER(runs);

  // Hazard vector
  double *pdTransitionHazard = (double *) R_alloc(iTransitions, sizeof(double));

  SEXP sexpRun;
  PROTECT(sexpRun = allocVector(VECSXP, iRuns));

  int iTotalUsedRandomNumbers = 0;

  // DiscTime Vector
  SEXP sexpD_time;
  PROTECT(sexpD_time = allocVector(REALSXP, iTotalSteps));
  double *pdDiscTime = REAL(sexpD_time);
  double dTmp = 0;
  for (k = 0; k < iTotalSteps; k++) {
    pdDiscTime[k] = dTmp;
    dTmp += dDelta;
  }

  SEXP sexpMarkingRowNames;
  PROTECT(sexpMarkingRowNames = allocVector(INTSXP, iTotalSteps));
  piTmp = INTEGER(sexpMarkingRowNames);
  for (k = 0; k < iTotalSteps; k++)
    piTmp[k] = k+1;

  double **ppdMarking = (double **) R_alloc(iPlaces, sizeof(double *));

  int iLevels = 7;
  int iGroups = pow(2, iLevels - 1);
  // Group holding the transitions that lie between boundaries
  int **ppiGroup = (int **) R_alloc(iGroups, sizeof(int *));
  // Number of transition each group has
  int *piGroupElm = (int *) R_alloc(iGroups, sizeof(int));
  // Total propensity hazard for each group
  int *piTotGroupTransitions = (int *) R_alloc(iGroups, sizeof(int));

  int *piTransitionInGroup = (int *) R_alloc(iTransitions, sizeof(int));
  int *piTransitionPositionInGroup = (int *) R_alloc(iTransitions, sizeof(int));

  int iGroup;
  for (iGroup = 0; iGroup < iGroups; iGroup++) {
    ppiGroup[iGroup] = (int *) R_alloc(iTransitions, sizeof(int));
  }

  node **ppnodeLevel = (node **) R_alloc(iLevels, sizeof(node *));
  int iLevel, iNode;
  int iNodesPerLevel = 1;
  for (iLevel = 0; iLevel < iLevels; iLevel++) {
    ppnodeLevel[iLevel] = (node *) R_alloc(iNodesPerLevel, sizeof(node));
    iNodesPerLevel *= 2;
  }
  node *pnodeRoot = &ppnodeLevel[0][0];
  pnodeRoot->parent = 0;
  node *pnodeGroup = ppnodeLevel[iLevels-1];

  iNodesPerLevel = 1;
  for (iLevel = 0; iLevel < iLevels; iLevel++) {
    for (iNode = 0; iNode < iNodesPerLevel; iNode++) {
      if (iLevel < iLevels-1) {
	ppnodeLevel[iLevel][iNode].iGroup = -1;
	ppnodeLevel[iLevel][iNode].left = &ppnodeLevel[iLevel+1][iNode*2];
	ppnodeLevel[iLevel][iNode].right = &ppnodeLevel[iLevel+1][iNode*2+1];
	ppnodeLevel[iLevel+1][iNode*2].parent = ppnodeLevel[iLevel+1][iNode*2+1].parent =
	  &ppnodeLevel[iLevel][iNode];
      } else {
	ppnodeLevel[iLevel][iNode].iGroup = iNode;
	ppnodeLevel[iLevel][iNode].left = ppnodeLevel[iLevel][iNode].right = 0;
      }
    }
    iNodesPerLevel *= 2;
  }

  double dNewHazard = 0;
  // Find minimum propensity
  double dMinHazard = DBL_MAX;
  for(iTransition = 0; iTransition < iTransitions; iTransition++) {
    switch(piHzType[iTransition]) {
    case HZ_DOUBLE:
      dNewHazard = pdH[iTransition];
      for(iPlacePtr = 0; iPlacePtr < piPreNZxRowTot[iTransition]; iPlacePtr++) {
	iPlace = piPreNZxRow[iTransition + iTransitions * iPlacePtr];
	for (k = 0; k < piPre[iTransition + iTransitions * iPlace]; k++)
	  dNewHazard *= (piPre[iTransition + iTransitions * iPlace] - k) / (double)(k+1);
      }
      if (dNewHazard > 0 && dNewHazard < dMinHazard)
	dMinHazard = dNewHazard;
      break;
    case HZ_CFUNCTION:	
      break;
    case HZ_RFUNCTION:
      break;
    }
  }

  GetRNGstate();
  for (iRun = 0; iRun < iRuns; iRun++) {

    int iUsedRandomNumbers = 0;
    Rprintf("%d ", iRun+1);

    // Totals for kind of transition vector
    SEXP sexpTotXTransition;
    PROTECT(sexpTotXTransition = allocVector(INTSXP, iTransitions));
    int *piTotTransitions = INTEGER(sexpTotXTransition);
  
    for(iTransition = 0; iTransition < iTransitions; iTransition++) {
      piTotTransitions[iTransition] = 0;
    }
  
    SEXP sexpMarking;
    PROTECT(sexpMarking = allocVector(VECSXP, iPlaces));
    //setAttrib(sexpMarking, R_NamesSymbol, place);
    //setAttrib(sexpMarking, R_RowNamesSymbol, sexpMarkingRowNames);
    //setAttrib(sexpMarking, R_ClassSymbol, ScalarString(mkChar("data.frame")));

    // Setup initial state
    double *pdTmp = REAL(M);
    for (iPlace = 0; iPlace < iPlaces; iPlace++) {
      SET_VECTOR_ELT(sexpMarking, iPlace, sexpTmp = allocVector(REALSXP, iTotalSteps));
      ppdMarking[iPlace] = REAL(sexpTmp);

      pdCrntMarking[iPlace] = pdTmp[iPlace];
    }
    
    for(iTransition = 0; iTransition < iTransitions; iTransition++) {
      pdTransitionHazard[iTransition] = 0;
      
      piTransitionInGroup[iTransition] = -1;
    }
    for (iGroup = 0; iGroup < iGroups; iGroup++) {
      piGroupElm[iGroup] = 0;
      piTotGroupTransitions[iGroup] = 0;
    }
    
    iNodesPerLevel = 1;
    for (iLevel = 0; iLevel < iLevels; iLevel++) {
      for (iNode = 0; iNode < iNodesPerLevel; iNode++) {
	ppnodeLevel[iLevel][iNode].dPartialAcumHazard = 0;
      }
      iNodesPerLevel *= 2;
    }
    node *pnode;
    
    double dTime = 0, dTarget = 0;
    int iTotTransitions = 0;

    int iStep = 0;
    int iInterruptCnt = 10000000;
    do {
      if (pCManage_time || sexpRManage_time) {
	double dEnd = 0;
	if (pCManage_time) {
	  dEnd = ((double(*)(double, double *)) pCManage_time)(dTarget, pdCrntMarking);
	} else {
	  defineVar(install("y"), sexpCrntMarking, rho);
	  PROTECT(sexpTmp = allocVector(REALSXP, 1));
	  *REAL(sexpTmp) = dTarget;
	  defineVar(install("StartTime"), sexpTmp, rho);
	  UNPROTECT_PTR(sexpTmp);

	  sexpTmp = eval(sexpRManage_time, rho);
	  dEnd = *REAL(VECTOR_ELT(sexpTmp,0));
	  for(iPlace = 0; iPlace < iPlaces; iPlace++) {
	    pdCrntMarking[iPlace] = REAL(VECTOR_ELT(sexpTmp,1))[iPlace];
	  }
	}
	iSectionSteps = (int)(dEnd / dDelta) + 1;
      }

      for(iPlace = 0; iPlace < iPlaces; iPlace++) {
	ppdMarking[iPlace][iStep] = pdCrntMarking[iPlace];
      }

      dTime = dTarget;
      dTarget += dDelta;
      
      // For the calculation of all hazards...
      int iLastTransition = iTransitions;
      
      do {
	// Get hazards only for the transitions associated with
	// places whose quantities changed in the last step.
	for(iTransitionPtr = 0; iTransitionPtr < piHazardsToModxRowTot[iLastTransition]; iTransitionPtr++) {
	  iTransition = piHazardsToModxRow[iLastTransition + (iTransitions + 1) * iTransitionPtr];
	  switch(piHzType[iTransition]) {
	  case HZ_DOUBLE:
	    dNewHazard = pdH[iTransition];
	    for(iPlacePtr = 0; iPlacePtr < piPreNZxRowTot[iTransition]; iPlacePtr++) {
	      iPlace = piPreNZxRow[iTransition + iTransitions * iPlacePtr];
	      for (k = 0; k < piPre[iTransition + iTransitions * iPlace]; k++)
		dNewHazard *= (pdCrntMarking[iPlace] - k) / (double)(k+1);
	    }
	    break;
	  case HZ_CFUNCTION:
	    dNewHazard = ((double(*)(double, double *)) pCFunction[iTransition])(dTime, pdCrntMarking);
	    break;
	  case HZ_RFUNCTION:
	    defineVar(install("y"), sexpCrntMarking, rho);
	    dNewHazard = REAL(eval(VECTOR_ELT(sexpFunction, iTransition), rho))[0];
	    break;
	  }

	  double dDeltaHazard;
	  frexp(dNewHazard/dMinHazard, &iGroup);
	  if (iGroup-- > 0) {
	    // Transition belongs to a group
	    if (iGroup == piTransitionInGroup[iTransition]) {
	      // Transitions will stay in same group as it was
	      dDeltaHazard = dNewHazard - pdTransitionHazard[iTransition];
	      pnode = &pnodeGroup[iGroup];
	      do {
		pnode->dPartialAcumHazard += dDeltaHazard;
	      } while ((pnode = pnode->parent));
	    } else if (piTransitionInGroup[iTransition] != -1) {
	      // Transition was in another group and needs to be moved to the new one
	      int iOldGroup = piTransitionInGroup[iTransition];
	      int iOldPositionInGroup = piTransitionPositionInGroup[iTransition];
	      dDeltaHazard = -pdTransitionHazard[iTransition];
	      pnode = &pnodeGroup[iOldGroup];
	      do {
		pnode->dPartialAcumHazard += dDeltaHazard;
	      } while ((pnode = pnode->parent));
	      piGroupElm[iOldGroup]--; // Old group will have one less element
	      // Now, piGroupElm[iOldGroup] is the index to last transition in group
	      if (iOldPositionInGroup != piGroupElm[iOldGroup]) {
		// Transition is not the last in group,
		// put the last transition in place of the one to be removed
		ppiGroup[iOldGroup][iOldPositionInGroup] = 
		  ppiGroup[iOldGroup][piGroupElm[iOldGroup]];
		// Update position of previous last transition in group
		piTransitionPositionInGroup[ppiGroup[iOldGroup][iOldPositionInGroup]] = 
		  iOldPositionInGroup;
	      }
	      dDeltaHazard = dNewHazard;
	      pnode = &pnodeGroup[iGroup];
	      do {
		pnode->dPartialAcumHazard += dDeltaHazard;
	      } while ((pnode = pnode->parent));
	      piTransitionInGroup[iTransition] = iGroup;
	      piTransitionPositionInGroup[iTransition] = piGroupElm[iGroup];
	      ppiGroup[iGroup][piGroupElm[iGroup]++] = iTransition;
	    } else if (piTransitionInGroup[iTransition] == -1) { // Transition was in no group
	      dDeltaHazard = dNewHazard;
	      pnode = &pnodeGroup[iGroup];
	      do {
		pnode->dPartialAcumHazard += dDeltaHazard;
	      } while ((pnode = pnode->parent));
	      piTransitionInGroup[iTransition] = iGroup;
	      piTransitionPositionInGroup[iTransition] = piGroupElm[iGroup];
	      ppiGroup[iGroup][piGroupElm[iGroup]++] = iTransition;
	    } else {
	    error("ERROR: Option not considered 1\n");
	    }
	  } else if (piTransitionInGroup[iTransition] != -1) {
	    // Transition will not belong to any group and needs to be removed from old
	    int iOldGroup = piTransitionInGroup[iTransition];
	    int iOldPositionInGroup = piTransitionPositionInGroup[iTransition];
	    dDeltaHazard = -pdTransitionHazard[iTransition];
	    pnode = &pnodeGroup[iOldGroup];
	    do {
	      pnode->dPartialAcumHazard += dDeltaHazard;
	    } while ((pnode = pnode->parent));
	    piGroupElm[iOldGroup]--; // Old group will have one less element
	    // Now, piGroupElm[iOldGroup] is the index to last transition in group
	    if (iOldPositionInGroup != piGroupElm[iOldGroup]) {
	      // Transition is not the last in group,
	      // put the last transition in place of the one to be removed
	      ppiGroup[iOldGroup][iOldPositionInGroup] = 
		ppiGroup[iOldGroup][piGroupElm[iOldGroup]];
	      // Update position of previous last transition in group
	      piTransitionPositionInGroup[ppiGroup[iOldGroup][iOldPositionInGroup]] = 
		iOldPositionInGroup;
	    }
	    piTransitionInGroup[iTransition] = -1;
	  }
	  pdTransitionHazard[iTransition] = dNewHazard;
	}
	
	// Get Time to transition
	dTime += exp_rand() / pnodeRoot->dPartialAcumHazard;
	iUsedRandomNumbers++;
	
	while (dTime >= dTarget) {
	  ++iStep;
	  // Update the state for the fixed incremented time.
	  for(iPlace = 0; iPlace < iPlaces; iPlace++)
	    ppdMarking[iPlace][iStep] = pdCrntMarking[iPlace];
	  if (iStep == iSectionSteps - 1)
	    goto EXIT_LOOP;

	  dTarget += dDelta;

	  // Force check if user interrupted
	  iInterruptCnt = 1;
	}
	if (! --iInterruptCnt) {
	  // Allow user interruption
	  R_CheckUserInterrupt();
	  iInterruptCnt = 10000000;
	}
	do {
	  // Find group containing firing transition
	  double dRnd = unif_rand() * pnodeRoot->dPartialAcumHazard;
	  iUsedRandomNumbers++;
	  pnode = pnodeRoot;
	  do {
	    if (dRnd < pnode->left->dPartialAcumHazard) {
	      pnode = pnode->left;
	    } else {
	      dRnd -= pnode->left->dPartialAcumHazard;
	      pnode = pnode->right;
	    }	      
	  } while (pnode->left);
	  // Next check is because
	  // once in a while it is generated a number that goes past
	  // the last group or selects a group with zero elements
	  // due to accumulated truncation errors.
	  // Discard this random number and try again.
	} while (piGroupElm[iGroup = pnode->iGroup] == 0);

	double dMaxInGroup = dMinHazard * pow(2, iGroup + 1);
	// Find transition in group
	while (1) {
	  if (! --iInterruptCnt) {
	    // Allow user interruption
	    R_CheckUserInterrupt();
	    iInterruptCnt = 10000000;
	  }
	  iTransitionPtr = (int) (unif_rand() * piGroupElm[iGroup]);
	  iUsedRandomNumbers++;
	  iTransition = ppiGroup[iGroup][iTransitionPtr];
	  iUsedRandomNumbers++;
	  if (pdTransitionHazard[iTransition] > unif_rand() * dMaxInGroup) {
	    piTotTransitions[iLastTransition = iTransition]++;
	    for(iPlacePtr = 0; iPlacePtr < piSNZxRowTot[iTransition]; iPlacePtr++) {
	      iPlace = piSNZxRow[iTransition + iTransitions * iPlacePtr];
	      
	      // Update the state
	      pdCrntMarking[iPlace] += piS[iTransition + iTransitions * iPlace];
	    }
	    break;
	  }
	}
	++iTotTransitions;
      } while (TRUE);
    EXIT_LOOP:;
      Rprintf(".");
    } while (iSectionSteps < iTotalSteps);
    iTotalUsedRandomNumbers += iUsedRandomNumbers;
    Rprintf("\t%d\t%d\t%d", iTotTransitions, iUsedRandomNumbers, iTotalUsedRandomNumbers);
#ifdef RB_SUBTIME
    c1 = clock();
    Rprintf ("\t To go: ");
    PrintfTime((double) (c1 - c0)/CLOCKS_PER_SEC/(iRun+1)*(iRuns-iRun-1));
#endif
    Rprintf ("\n");
    
    SEXP sexpTotTransitions;
    PROTECT(sexpTotTransitions = allocVector(INTSXP, 1));
    INTEGER(sexpTotTransitions)[0] = iTotTransitions;

    SEXP sexpThisRun;
    PROTECT(sexpThisRun = allocVector(VECSXP, 3));

    SET_VECTOR_ELT(sexpThisRun, 0, sexpMarking);
    UNPROTECT_PTR(sexpMarking);
    SET_VECTOR_ELT(sexpThisRun, 1, sexpTotXTransition);
    UNPROTECT_PTR(sexpTotXTransition);
    SET_VECTOR_ELT(sexpThisRun, 2, sexpTotTransitions);
    UNPROTECT_PTR(sexpTotTransitions);

    SEXP sexpNames;
    PROTECT(sexpNames = allocVector(VECSXP, 3));
    SET_VECTOR_ELT(sexpNames, 0, mkChar("M"));
    SET_VECTOR_ELT(sexpNames, 1, mkChar("transitions"));
    SET_VECTOR_ELT(sexpNames, 2, mkChar("tot.transitions"));
    setAttrib(sexpThisRun, R_NamesSymbol, sexpNames);
    UNPROTECT_PTR(sexpNames);

    SET_VECTOR_ELT(sexpRun, iRun, sexpThisRun);
    UNPROTECT_PTR(sexpThisRun);
  }
  PutRNGstate();

  SEXP sexpAns;
  PROTECT(sexpAns = allocVector(VECSXP, 4));
  SET_VECTOR_ELT(sexpAns, 0, place);
  SET_VECTOR_ELT(sexpAns, 1, transition);
  SET_VECTOR_ELT(sexpAns, 2, sexpD_time);
  UNPROTECT_PTR(sexpD_time);
  SET_VECTOR_ELT(sexpAns, 3, sexpRun);
  UNPROTECT_PTR(sexpRun);

  SEXP sexpNames;
  PROTECT(sexpNames = allocVector(VECSXP, 4));
  SET_VECTOR_ELT(sexpNames, 0, mkChar("place"));
  SET_VECTOR_ELT(sexpNames, 1, mkChar("transition"));
  SET_VECTOR_ELT(sexpNames, 2, mkChar("dt"));
  SET_VECTOR_ELT(sexpNames, 3, mkChar("run"));
  setAttrib(sexpAns, R_NamesSymbol, sexpNames);
  UNPROTECT_PTR(sexpNames);

#ifdef RB_TIME
  c1 = clock();
  double dCpuTime = (double) (c1 - c0)/CLOCKS_PER_SEC;
  Rprintf ("Elapsed CPU time: ");
  PrintfTime(dCpuTime);
  Rprintf ("\t(%fs)\n", dCpuTime);
#endif

  if (sexpRManage_time)
    UNPROTECT_PTR(sexpRManage_time);
  UNPROTECT_PTR(sexpFunction);
  UNPROTECT_PTR(sexpMarkingRowNames);
  UNPROTECT_PTR(sexpCrntMarking);
  UNPROTECT_PTR(sexpAns);
  return(sexpAns);
}
示例#19
0
SEXP gridCallback(GEevent task, pGEDevDesc dd, SEXP data) {
    SEXP result = R_NilValue;
    SEXP valid, scale;
    SEXP gridState;
    GESystemDesc *sd;
    SEXP currentgp;
    SEXP gsd;
    SEXP devsize;
    R_GE_gcontext gc;
    switch (task) {
    case GE_InitState:
	/* Create the initial grid state for a device
	 */
	PROTECT(gridState = createGridSystemState());
	/* Store that state with the device for easy retrieval
	 */
	sd = dd->gesd[gridRegisterIndex];
	sd->systemSpecific = (void*) gridState;
	/* Initialise the grid state for a device
	 */
	fillGridSystemState(gridState, dd);
	/* Also store the state beneath a top-level variable so
	 * that it does not get garbage-collected
	 */
	globaliseState(gridState);
        /* Indicate success */
        result = R_BlankString;
	UNPROTECT(1);
	break;
    case GE_FinaliseState:
	sd = dd->gesd[gridRegisterIndex];
	/* Simply detach the system state from the global variable
	 * and it will be garbage-collected
	 */
	deglobaliseState((SEXP) sd->systemSpecific);
	/* Also set the device pointer to NULL
	 */
	sd->systemSpecific = NULL;	
	break;
    case GE_SaveState:
	break;
    case GE_RestoreState:
	gsd = (SEXP) dd->gesd[gridRegisterIndex]->systemSpecific;
	PROTECT(devsize = allocVector(REALSXP, 2));
	getDeviceSize(dd, &(REAL(devsize)[0]), &(REAL(devsize)[1]));
	SET_VECTOR_ELT(gsd, GSS_DEVSIZE, devsize);
	UNPROTECT(1);
	/* Only bother to do any grid drawing setup 
	 * if there has been grid output
	 * on this device.
	 */
	if (LOGICAL(gridStateElement(dd, GSS_GRIDDEVICE))[0]) {
	    if (LOGICAL(gridStateElement(dd, GSS_ENGINEDLON))[0]) {
		/* The graphics engine is about to replay the display list
		 * So we "clear" the device and reset the grid graphics state
		 */
		/* There are two main situations in which this occurs:
		 * (i) a screen is resized
		 *     In this case, it is ok-ish to do a GENewPage
		 *     because that has the desired effect and no 
		 *     undesirable effects because it only happens on
		 *     a screen device -- a new page is the same as
		 *     clearing the screen
		 * (ii) output on one device is copied to another device
		 *     In this case, a GENewPage is NOT a good thing, however,
		 *     here we will start with a new device and it will not
		 *     have any grid output so this section will not get called
		 *     SO we will not get any unwanted blank pages.
		 *
		 * All this is a bit fragile;  ultimately, what would be ideal
		 * is a dev->clearPage primitive for all devices in addition
		 * to the dev->newPage primitive
		 */ 
		currentgp = gridStateElement(dd, GSS_GPAR);
		gcontextFromgpar(currentgp, 0, &gc, dd);
		GENewPage(&gc, dd);
		initGPar(dd);
		initVP(dd);
		initOtherState(dd);
	    } else {
		/*
		 * If we have turned off the graphics engine's display list
		 * then we have to redraw the scene ourselves
		 */
		SEXP fcall;
		PROTECT(fcall = lang1(install("draw.all")));
		eval(fcall, R_gridEvalEnv); 
		UNPROTECT(1);
	    }
	}
	break;
    case GE_CopyState:
	break;
    case GE_CheckPlot:
	PROTECT(valid = allocVector(LGLSXP, 1));
	LOGICAL(valid)[0] = TRUE;
	UNPROTECT(1);
	result = valid;
    case GE_SaveSnapshotState:
	break;
    case GE_RestoreSnapshotState:
	break;
    case GE_ScalePS:
	/*
	 * data is a numeric scale factor
	 */
	PROTECT(scale = allocVector(REALSXP, 1));
	REAL(scale)[0] = REAL(gridStateElement(dd, GSS_SCALE))[0]*
	    REAL(data)[0];
	setGridStateElement(dd, GSS_SCALE, scale);
	UNPROTECT(1);
	break;
    }
    return result;
}
SEXP R_colAppend_sgCMatrix(SEXP x, SEXP y, SEXP R_s) {
    if (!inherits(x, "sgCMatrix"))
	error("'x' not of class sgCMatrix");
    if (!inherits(y, "sgCMatrix"))
	error("'y' not of class sgCMatrix");
    if (INTEGER(getAttrib(x, install("Dim")))[1] !=
	INTEGER(getAttrib(y, install("Dim")))[1])
	error("the number of columns of 'x' and 'y' do not conform");
    if (TYPEOF(R_s) != LGLSXP)
	error("'s' not of storage type logical");
    int i, k, fx, lx, fy, ly, nr, n;
    SEXP r, pr, ir, px, ix, py, iy;

    nr = INTEGER(getAttrib(x, install("Dim")))[0];
    if (nr != INTEGER(getAttrib(y, install("Dim")))[0])
	error("the number of rows of 'x' and 'y' do not conform");

    px = getAttrib(x, install("p"));
    py = getAttrib(y, install("p"));
    if (LENGTH(px) != LENGTH(py))
	error("slots p of 'x' and 'y' do not conform");

    ix = getAttrib(x, install("i"));
    iy = getAttrib(y, install("i"));

    n = (LOGICAL(R_s)[0] == FALSE) ? 0 : LENGTH(px)-1;	    // seperators

    PROTECT(r = NEW_OBJECT(MAKE_CLASS("sgCMatrix")));
    setAttrib(r, install("p"), (pr = allocVector(INTSXP, LENGTH(px))));
    setAttrib(r, install("i"), (ir = allocVector(INTSXP, LENGTH(ix)+LENGTH(iy)+n)));

    fx = fy = n = INTEGER(pr)[0] = 0;
    for (i = 1; i < LENGTH(px); i++) {
	lx = INTEGER(px)[i];
	for (k = fx; k < lx; k++)
	    INTEGER(ir)[n++] = INTEGER(ix)[k];
	ly = INTEGER(py)[i];
	if (LOGICAL(R_s)[0] == TRUE)
	    INTEGER(ir)[n++] = nr;
	for (k = fy; k < ly; k++)
	    INTEGER(ir)[n++] = INTEGER(iy)[k];
	INTEGER(pr)[i] = n;
	fx = lx;
	fy = ly;
    }
    setAttrib(r, install("Dim"), (ir = allocVector(INTSXP, 2)));
    INTEGER(ir)[0] = (LOGICAL(R_s)[0] == FALSE) ? nr : nr + 1;
    INTEGER(ir)[1] = LENGTH(pr)-1;

    setAttrib(r, install("Dimnames"), (ir = allocVector(VECSXP, 2)));
    
    ix = getAttrib(x, install("Dimnames"));
    iy = getAttrib(y, install("Dimnames"));

    if (isNull((px = VECTOR_ELT(ix, 0))))
	px = VECTOR_ELT(iy, 0);
    if (isNull(px) || LOGICAL(R_s)[0] == FALSE)
	SET_VECTOR_ELT(ir, 0, px);
    else {
	SEXP s;

	SET_VECTOR_ELT(ir, 0, (s = allocVector(STRSXP, nr+1)));
	for (k = 0; k < nr; k++)
	    SET_STRING_ELT(s, k, VECTOR_ELT(px, k));
	SET_STRING_ELT(s, k, R_BlankString);
    }

    if (isNull((px = VECTOR_ELT(ix, 1))))
	SET_VECTOR_ELT(ir, 1, VECTOR_ELT(iy, 1));
    else
	SET_VECTOR_ELT(ir, 1, px);

    if (isNull((ix = getAttrib(ix, R_NamesSymbol))))
	setAttrib(ir, R_NamesSymbol, getAttrib(iy, R_NamesSymbol));
    else
	setAttrib(ir, R_NamesSymbol, ix);

    UNPROTECT(1);

    return r;
}
示例#21
0
SEXP prop_part(SEXP TREES, SEXP nbtree, SEXP keep_partitions)
{
    int i, j, k, l, KeepPartition, Ntree, Ntip, Nnode, Npart, NpartCurrent, *no;
    SEXP bp, ans, nbtip, nbnode, number;

    PROTECT(nbtree = coerceVector(nbtree, INTSXP));
    PROTECT(keep_partitions = coerceVector(keep_partitions, INTSXP));
    Ntree = *INTEGER(nbtree);
    KeepPartition = *INTEGER(keep_partitions);


    Ntip = LENGTH(getListElement(VECTOR_ELT(TREES, 0), "tip.label"));
    Nnode = *INTEGER(getListElement(VECTOR_ELT(TREES, 0), "Nnode"));

    PROTECT(nbtip = allocVector(INTSXP, 1));
    PROTECT(nbnode = allocVector(INTSXP, 1));
    INTEGER(nbtip)[0] = Ntip;
    INTEGER(nbnode)[0] = Nnode;

    if (KeepPartition) Npart = Ntree*(Nnode - 1) + 1;
    else Npart = Nnode;

    PROTECT(number = allocVector(INTSXP, Npart));
    no = INTEGER(number); /* copy the pointer */
    /* The first partition in the returned list has all tips,
       so it is observed in all trees: */
    no[0] = Ntree;
    /* The partitions in the first tree are obviously observed once: */
    for (i = 1; i < Nnode; i++) no[i] = 1;

    if (KeepPartition) {
        for (i = Nnode; i < Npart; i++) no[i] = 0;

        PROTECT(ans = allocVector(VECSXP, Npart));
	PROTECT(bp = bipartition(getListElement(VECTOR_ELT(TREES, 0), "edge"),
				 nbtip, nbnode));
	for (i = 0; i < Nnode; i++)
	  SET_VECTOR_ELT(ans, i, VECTOR_ELT(bp, i));
	UNPROTECT(1);
    } else {
        PROTECT(ans = bipartition(getListElement(VECTOR_ELT(TREES, 0), "edge"),
				  nbtip, nbnode));
    }

    NpartCurrent = Nnode;

    /* We start on the 2nd tree: */
    for (k = 1; k < Ntree; k++) {
        PROTECT(bp = bipartition(getListElement(VECTOR_ELT(TREES, k), "edge"),
				 nbtip, nbnode));
	for (i = 1; i < Nnode; i++) {
	    j = 1;
next_j:
	    if (SameClade(VECTOR_ELT(bp, i), VECTOR_ELT(ans, j))) {
	        no[j]++;
		continue;
	    }
	    j++;
	    if (j < NpartCurrent) goto next_j;
	    if (KeepPartition) {
	        no[NpartCurrent]++;
		SET_VECTOR_ELT(ans, NpartCurrent, VECTOR_ELT(bp, i));
		NpartCurrent++;
	    }
	}
	UNPROTECT(1);
    }

    if (KeepPartition && NpartCurrent < Npart) {
        PROTECT(bp = allocVector(VECSXP, NpartCurrent));
	for (i = 0; i < NpartCurrent; i++)
	  SET_VECTOR_ELT(bp, i, VECTOR_ELT(ans, i));
	setAttrib(bp, install("number"), number);
	UNPROTECT(7);
	return bp;
    } else {
        setAttrib(ans, install("number"), number);
	UNPROTECT(6);
	return ans;
    }
} /* prop_part */
SEXP R_valid_sgCMatrix(SEXP x) {
    if (!inherits(x, "sgCMatrix"))
	error("'x' not of class sgCMatrix");
    int i, k, f, l;
    SEXP px, ix, dx;

    px = getAttrib(x, install("p"));
    ix = getAttrib(x, install("i"));
    dx = getAttrib(x, install("Dim"));
    
    if (isNull(px) || isNull(ix) || isNull(dx))
	return mkString("slot p, i, or Dim is NULL");

    if (TYPEOF(px) != INTSXP || TYPEOF(ix) != INTSXP || TYPEOF(dx) != INTSXP)
	return mkString("slot p, i, or Dim not of storage type integer");

    if (LENGTH(dx) != 2 || INTEGER(dx)[0] < 0 || INTEGER(dx)[1] < 0)
	return mkString("slot Dim invalid");

    if (INTEGER(dx)[1] != LENGTH(px)-1)
	return mkString("slot p and Dim do not conform");

    f = l = INTEGER(px)[0];
    if (f != 0)
	return mkString("slot p invalid");

    for (i = 1; i < LENGTH(px); i++) {
	l = INTEGER(px)[i];
	if (l < f)
	    return mkString("slot p invalid");
	f = l;
    }
    if (l != LENGTH(ix))
	return mkString("slot p and i do not conform");

    if (l > 0) {
	f = l = INTEGER(ix)[0];
	for (i = 1; i < LENGTH(ix); i++) {
	    k = INTEGER(ix)[i];
	    if (k < f)
		f = k;
	    else
	    if (k > l)
		l = k;
	}
	if (f < 0 || l > INTEGER(dx)[0]-1)
	    return mkString("slot i invalid");
    }

    ix = getAttrib(x, install("Dimnames"));

    if (LENGTH(ix) != 2 || TYPEOF(ix) != VECSXP)
	return mkString("slot Dimnames invalid");

    px = VECTOR_ELT(ix, 0);
    if (!isNull(px)) {
	if (TYPEOF(px) != STRSXP)
	    return mkString("slot Dimnames invalid");
	if (LENGTH(px) != INTEGER(dx)[0])
	    return mkString("slot Dim and Dimnames do not conform");
    }

    px = VECTOR_ELT(ix, 1);
    if (!isNull(px)) {
	if (TYPEOF(px) != STRSXP)
	    return mkString("slot Dimnames invalid");
	if (LENGTH(px) != INTEGER(dx)[1])
	    return mkString("slot Dim and Dimnames do not conform");
    }

    return ScalarLogical(TRUE);
}
void CNcdNodeActivate::ActivateL()
    {
    DLTRACEIN((""));

    // Note that ownership is not transferred here.
    // So, do not add to the cleanup stack.
    // When the items have been installed, they may be activated.
    // Install proxy contains theme name and file information that
    // can be used to activate items.
    CNcdNodeInstallProxy* install( Metadata().Install() );

    if ( install != NULL && install->IsInstalledL() )
        {
        // Create the service that can handle activations
        MNcdDeviceService* service( 
            NcdDeviceInteractionFactory::CreateDeviceServiceLC() );
            
        if ( service == NULL )
            {
            DLERROR(("Could not create service for active interface"));
            
            // For debugging purposes
            DASSERT( EFalse );
            
            User::Leave( KErrNotFound );
            }
    
        // Now we have the install interface to use and to check if some
        // of its material could be activated. Activation may be done
        // after the item has been installed.


        // NOTICE: If you add or remove functionality here,
        // then remember to update the CNcdNodeProxy::InternalizeActivateL()
        // function accordingly. So, the MNcdNodeActivate interface can be
        // provided from the API in correct situations.

        RCatalogsArray<MNcdInstalledContent> content( install->InstalledContentL() );
        CleanupResetAndDestroyPushL( content );

        TBool setSomething = EFalse;
        for ( TInt i = 0; i < content.Count(); ++i )
            {
            MNcdInstalledTheme* theme = content[i]->QueryInterfaceLC<MNcdInstalledTheme>();
            if ( theme ) 
                {
                SetThemeL( *theme, *service );
                setSomething = ETrue;
                CleanupStack::PopAndDestroy( theme );
                break;
                }
                        
            MNcdInstalledFile* file = content[i]->QueryInterfaceLC<MNcdInstalledFile>();
            if ( file )
                {
                SetContentFileL( *file, *install, *service );
                setSomething = ETrue;
                CleanupStack::PopAndDestroy( file );
                break;
                }                       
            }

        CleanupStack::PopAndDestroy( &content );
        
        if ( !setSomething )
            {
            User::Leave( KErrNotFound );
            }
            

        CleanupStack::PopAndDestroy( service );
        }

    DLTRACEOUT((""));
    }
SEXP R_rowSubset_sgCMatrix(SEXP x, SEXP s) {
    if (!inherits(x, "sgCMatrix"))
	error("'x' not of class sgCMatrix");
    int i, j, k, f, l, n, *o;
    SEXP r, dx, px, ix, pr, ir;
	        
    dx = getAttrib(x, install("Dimnames"));
#ifdef _COMPAT_
    r = CONS(dx, ATTRIB(x));
    SET_TAG(r, R_DimNamesSymbol);
    SET_ATTRIB(x, r);

    PROTECT(s = arraySubscript(0, s, getAttrib(x, install("Dim")), getAttrib, (STRING_ELT), x));
    
    SET_ATTRIB(x, CDR(r));
#else
    PROTECT(s = _int_array_subscript(0, s, "Dim", "Dimnames", x, TRUE, R_NilValue));
#endif

    n = INTEGER(getAttrib(x, install("Dim")))[0];

    o = INTEGER(PROTECT(allocVector(INTSXP, n)));
    memset(o, 0, sizeof(int) * n);

    l = 1;
    for (i = 0; i < LENGTH(s); i++) {
	j = INTEGER(s)[i];
	if (j == NA_INTEGER)
	    error("invalid subscript(s)");
	if (j < l)
	    error("invalid subscript(s)");
	if (o[j-1] == 0)
	    o[j-1] = i+1;
	else
	    error("invalid subscript(s)");
	l = j;
    }

    ix = getAttrib(x, install("i"));

    n = 0;
    if (LENGTH(s))
	for (i = 0; i < LENGTH(ix); i++)
	    if (o[INTEGER(ix)[i]])
		n++;

    px = getAttrib(x, install("p"));

    PROTECT(r = NEW_OBJECT(MAKE_CLASS("sgCMatrix")));
    setAttrib(r, install("p"), (pr = allocVector(INTSXP, LENGTH(px))));
    setAttrib(r, install("i"), (ir = allocVector(INTSXP, n)));

    f = n = INTEGER(pr)[0] = 0;
    for (i = 1; i < LENGTH(px); i++) {
	l = INTEGER(px)[i];
	if (LENGTH(s))
	    for (k = f; k < l; k++) {
		j = o[INTEGER(ix)[k]];
		if (j)
		    INTEGER(ir)[n++] = j-1;
	    }
	INTEGER(pr)[i] = n;
	f = l;
    }
    
    setAttrib(r, install("Dim"), (ir = allocVector(INTSXP, 2)));
    INTEGER(ir)[0] = LENGTH(s);
    INTEGER(ir)[1] = LENGTH(px)-1;

    if (isNull((ix = VECTOR_ELT(dx, 0))))
	setAttrib(r, install("Dimnames"), dx);
    else {
	setAttrib(r, install("Dimnames"), (ir = allocVector(VECSXP, 2)));
	setAttrib(ir, R_NamesSymbol, getAttrib(dx, R_NamesSymbol));
	SET_VECTOR_ELT(ir, 1, VECTOR_ELT(dx, 1));
	if (LENGTH(s) > 0) {
	    SET_VECTOR_ELT(ir, 0, (pr = allocVector(STRSXP, LENGTH(s))));
	    for (i = 0; i < LENGTH(s); i++)
		SET_STRING_ELT(pr, i, STRING_ELT(ix, INTEGER(s)[i]-1));
	} else
	    SET_VECTOR_ELT(ir, 0, R_NilValue);
    }

    UNPROTECT(3);

    return r;
}
示例#25
0
文件: edit.c 项目: jagdeesh109/RRO
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    int   i, rc;
    ParseStatus status;
    SEXP  x, fn, envir, ed, src, srcfile, Rfn;
    char *filename, *editcmd;
    const char *cmd;
    const void *vmaxsave;
    FILE *fp;
#ifdef Win32
    SEXP ti;
    char *title;
#endif

	checkArity(op, args);

    vmaxsave = vmaxget();

    x = CAR(args); args = CDR(args);
    if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
    else envir = R_NilValue;
    PROTECT(envir);

    fn = CAR(args); args = CDR(args);
    if (!isString(fn))
	error(_("invalid argument to edit()"));

    if (LENGTH(STRING_ELT(fn, 0)) > 0) {
	const char *ss = translateChar(STRING_ELT(fn, 0));
	filename = R_alloc(strlen(ss), sizeof(char));
	strcpy(filename, ss);
    }
    else filename = DefaultFileName;

    if (x != R_NilValue) {
	if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
	    errorcall(call, _("unable to open file"));
	if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
	PROTECT(src = deparse1(x, 0, FORSOURCING)); /* deparse for sourcing, not for display */
	for (i = 0; i < LENGTH(src); i++)
	    fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
	UNPROTECT(1); /* src */
	fclose(fp);
    }
#ifdef Win32
    ti = CAR(args);
#endif
    args = CDR(args);
    ed = CAR(args);
    if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
    cmd = translateChar(STRING_ELT(ed, 0));
    if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
    editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
    if (!strcmp(cmd,"internal")) {
	if (!isString(ti))
	    error(_("'title' must be a string"));
	if (LENGTH(STRING_ELT(ti, 0)) > 0) {
	    title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
	    strcpy(title, CHAR(STRING_ELT(ti, 0)));
	} else {
	    title = R_alloc(strlen(filename)+1, sizeof(char));
	    strcpy(title, filename);
	}
	Rgui_Edit(filename, CE_NATIVE, title, 1);
    }
    else {
	/* Quote path if necessary */
	if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
	    sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
	else
	    sprintf(editcmd, "%s \"%s\"", cmd, filename);
	rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
	if (rc == NOLAUNCH)
	    errorcall(call, _("unable to run editor '%s'"), cmd);
	if (rc != 0)
	    warningcall(call, _("editor ran but returned error status"));
    }
#else
    if (ptr_R_EditFile)
	rc = ptr_R_EditFile(filename);
    else {
	sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces
	rc = R_system(editcmd);
    }
    if (rc != 0)
	errorcall(call, _("problem with running editor %s"), cmd);
#endif

    if (asLogical(GetOption1(install("keep.source")))) {
	PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
	PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
	PROTECT(src = eval(src, R_BaseEnv));
	PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
	PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
	srcfile = eval(srcfile, R_BaseEnv);
	UNPROTECT(5);
    } else
    	srcfile = R_NilValue;
    PROTECT(srcfile);
    
    /* <FIXME> setup a context to close the file, and parse and eval
       line by line */
    if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
	errorcall(call, _("unable to open file to read"));

    x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
    fclose(fp);

    if (status != PARSE_OK)
	errorcall(call,
		  _("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
    R_ResetConsole();
    {   /* can't just eval(x) here */
	int j, n;
	SEXP tmp = R_NilValue;

	n = LENGTH(x);
	for (j = 0 ; j < n ; j++)
	    tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv);
	x = tmp;
    }
    if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
	SET_CLOENV(x, envir);
    UNPROTECT(3);
    vmaxset(vmaxsave);
    return x;
}
示例#26
0
SEXP Xest_gen_Q_C( CFmMatrix* pFmYDelt, CFmMatrix* pFmZ, CFmMatrix* pFmX, CFmVector* pFmMaf, CFmVector* pFmParNull)
{
	CFmNewTemp fmRef;

	double sig_a2  = pow(pFmParNull->Get(0), 2);
	double sig_b2  = pow(pFmParNull->Get(1), 2);
	double sig_e2  = pow(pFmParNull->Get(2), 2);
	double par_rho = pFmParNull->Get(3);

	int N = pFmYDelt->GetNumRows();
	int M = pFmYDelt->GetNumCols();
	int K = pFmMaf->GetLength();

//Rprintf("N=%d, M=%d, K=%d a2=%f b2=%f e2=%f rho=%f\n", N, M, K, sig_a2, sig_b2, sig_e2, par_rho);

	CFmMatrix fmAR1( M, M );
	for(int i=0; i<M; i++)
	for(int j=0; j<M; j++)
		fmAR1.Set( i, j, pow( par_rho, abs( i - j ) ) );

	CFmMatrix fmV_j( M, M );
	CFmMatrix fmV_j1( M, M );
	//CFmMatrix fmDiag( M, true, 1.0 ); //???HERE
	CFmMatrix fmDiag( M, M );
	for(int i=0; i<M; i++) fmDiag.Set(i, i, 1.0);

	fmV_j = (fmV_j + 1.0) * sig_a2 +  fmAR1 * sig_b2 + fmDiag * sig_e2;
	fmV_j1 = fmV_j.GetInverted();

	CFmVector fmVectMj_x(N, 0.0);
	CFmVector fmVecTmp (M, 0.0);
	CFmVector fmVecTmp2(M, 0.0);
	CFmMatrix fmVj_i(M, M);

	CFmMatrix** ppVj = Calloc(N, CFmMatrix*);
	CFmVector** ppYj = Calloc( N, CFmVector*);

	for(int i=0; i<N ;i++)
	{
		fmVecTmp = pFmYDelt->GetRow(i);
		fmVecTmp2.Resize(0);
		for(int j=0; j<fmVecTmp.GetLength(); j++)
		{
			if (!isnan(fmVecTmp[j]))
				fmVecTmp2.Put(j);
		}

		int NonNA = fmVecTmp2.GetLength();

		ppVj[i] = new (fmRef) CFmMatrix(NonNA, NonNA);
		ppYj[i] = new (fmRef) CFmVector(NonNA, 0.0);

		fmVj_i.Resize(NonNA, NonNA);
		if (NonNA>0)
		{
			for( int k=0; k<NonNA; k++)
			for( int l=0; l<NonNA; l++)
				fmVj_i.Set(k, l,fmV_j.Get( (int)fmVecTmp2[k], (int)fmVecTmp2[l] ) );
			*(ppVj[i]) = fmVj_i.GetInverted( );

			fmVecTmp.RemoveNan();
			*(ppYj[i]) = fmVecTmp;

			fmVectMj_x[i] = fmVecTmp.GetLength();
		}

	}

	CFmVector fmQi(1, 0.0);
	CFmMatrix fmTrans(1, N );
	double fQv=0.0;

	for(int i=0; i<K ;i++)
	{
		fmQi.Resize(1);
		for(int j=0; j<N ;j++)
		{
			fmTrans.Resize(1, fmVectMj_x[j]);
			for( int l=0;l<(int)(fmVectMj_x[j]);l++)
				fmTrans.Set(0, l, 1.0);
			fmQi = (fmTrans * (*(ppVj[j])) * (*(ppYj[j])) * pFmZ->Get(j,i)).GetRow(0) + fmQi;
		}

		fmQi = fmQi*fmQi;
		fQv = fQv + fmQi.Sum();
	}

	fQv = fQv/2.0;

	int NX = pFmX->GetNumCols();
	CFmMatrix fmW0( K, K );
	CFmMatrix fmW1( K, NX );
	CFmMatrix fmW2( NX,NX );
	CFmMatrix fmW3( NX,K );
	CFmMatrix fmKrZ( 0,0);
	CFmMatrix fmKrX( 0,0);
	CFmMatrix fmKron( N, 1 );

	for(int i=0; i<N; i++)
	{
		fmKron.Resize( fmVectMj_x[i],1 );
		for(int k=0;k<fmVectMj_x[i]; k++) fmKron.Set(k, 0, 1.0);

		fmVecTmp = pFmZ->GetRow(i);
		kronecker_vm( fmVecTmp, fmKron, &fmKrZ );
		fmVecTmp = pFmX->GetRow(i);
		kronecker_vm( fmVecTmp, fmKron, &fmKrX );

		fmW0 = fmW0 + fmKrZ.GetTransposed() * (*(ppVj[i])) * fmKrZ;
		fmW1 = fmW1 + fmKrZ.GetTransposed() * (*(ppVj[i])) * fmKrX;
		fmW2 = fmW2 + fmKrX.GetTransposed() * (*(ppVj[i])) * fmKrX;
		fmW3 = fmW3 + fmKrX.GetTransposed() * (*(ppVj[i])) * fmKrZ;
	}

	CFmMatrix fmQw( K, K );

	fmQw = fmW0 - fmW1 * fmW2.GetInverted() * fmW3;
	fmQw = fmQw / 2.0;

	for(int i=0; i<N; i++) { destroy( ppVj[i] );}
	for(int i=0; i<N; i++) { destroy( ppYj[i] );}
	Free(ppVj);
	Free(ppYj);

	//double fQv = 0.5;
	//CFmMatrix fmQw( K, K );
	//for(int i=0; i<K; i++)  fmQw.Set(i, i, i+1);

	SEXP sRet, t;
   	PROTECT(sRet = t = allocList(2));

	SEXP expVS = GetSEXP(&fmQw);
	SETCAR( t, expVS );
	SET_TAG(t, install("w") );
	t = CDR(t);

	CFmVector frmQv(1, fQv);
	SEXP expVS1 = GetSEXP(&frmQv);
	SETCAR( t, expVS1 );
	SET_TAG(t, install("v") );
	t = CDR(t);

	UNPROTECT(1);

    return(sRet);
}
示例#27
0
SEXP Rscc_check_clustering(const SEXP R_clustering,
                           const SEXP R_size_constraint,
                           const SEXP R_type_labels,
                           const SEXP R_type_constraints,
                           const SEXP R_primary_data_points)
{
	if (!isInteger(R_clustering)) {
		iRscc_error("`R_clustering` is not a valid clustering object.");
	}
	if (!isInteger(getAttrib(R_clustering, install("cluster_count")))) {
		iRscc_error("`R_clustering` is not a valid clustering object.");
	}
	if (!isInteger(R_size_constraint)) {
		iRscc_error("`R_size_constraint` must be integer.");
	}
	if (isNull(R_type_labels)) {
		if (!isNull(R_type_constraints)) {
			iRscc_error("`R_type_constraints` must be NULL when no types are supplied.");
		}
	} else {
		if (!isInteger(R_type_labels)) {
			iRscc_error("`R_type_labels` must be factor, integer or NULL.");
		}
		if (!isInteger(R_type_constraints)) {
			iRscc_error("`R_type_constraints` must be integer.");
		}
	}
	if (!isNull(R_primary_data_points) && !isInteger(R_primary_data_points)) {
		iRscc_error("`R_primary_data_points` must be NULL or integer.");
	}

	const uint64_t num_data_points = (uint64_t) xlength(R_clustering);
	const uint64_t num_clusters = (uint64_t) asInteger(getAttrib(R_clustering, install("cluster_count")));
	if (num_clusters == 0) {
		iRscc_error("`R_clustering` is empty.");
	}

	scc_ClusterOptions options = scc_get_default_options();

	options.size_constraint = (uint32_t) asInteger(R_size_constraint);

	if (isInteger(R_type_labels) && isInteger(R_type_constraints)) {
		const uint32_t num_types = (uint32_t) xlength(R_type_constraints);
		const size_t len_type_labels = (size_t) xlength(R_type_labels);
		if (len_type_labels != num_data_points) {
			iRscc_error("`R_type_labels` does not match `R_clustering`.");
		}
		if (num_types >= 2) {
			uint32_t* const type_constraints = (uint32_t*) R_alloc(num_types, sizeof(uint32_t)); // Automatically freed by R on return
			if (type_constraints == NULL) iRscc_error("Could not allocate memory.");
			const int* const tmp_type_constraints = INTEGER(R_type_constraints);
			for (size_t i = 0; i < num_types; ++i) {
				if (tmp_type_constraints[i] < 0) {
				  iRscc_error("Negative type size constraint.");
				}
				type_constraints[i] = (uint32_t) tmp_type_constraints[i];
			}

			options.num_types = num_types;
			options.type_constraints = type_constraints;
			options.len_type_labels = len_type_labels;
			options.type_labels = INTEGER(R_type_labels);
		}
	}

	if (isInteger(R_primary_data_points)) {
		options.len_primary_data_points = (size_t) xlength(R_primary_data_points);
		options.primary_data_points = INTEGER(R_primary_data_points);
	}

	scc_ErrorCode ec;
	scc_Clustering* clustering;
	if ((ec = scc_init_existing_clustering(num_data_points,
	                                       num_clusters,
	                                       INTEGER(R_clustering),
	                                       false,
	                                       &clustering)) != SCC_ER_OK) {
		iRscc_scc_error();
	}

	bool is_OK = false;
	if ((ec = scc_check_clustering(clustering,
	                               &options,
	                               &is_OK)) != SCC_ER_OK) {
		scc_free_clustering(&clustering);
		iRscc_scc_error();
	}

	scc_free_clustering(&clustering);

	return ScalarLogical((int) is_OK);
}
示例#28
0
static int get_special(SEXP variable, struct design *s, struct design *r, struct design2 *d,
		       struct variable *v)
{
	SEXP i1, i2, labels, l;
	double xi, *xi1, *xi2;
	size_t ni1, ni2, k, i, j, size, rank;
	struct design *a;
	const struct var **var;
	const struct var2 **var2;

	if (!(inherits(variable, "interval")
		|| inherits(variable, "intervals")
		|| inherits(variable, "intervals2")))
		DOMAIN_ERROR("unknown variable type");


	/* extract intervals */
	i1 = VECTOR_ELT(variable, 0);
	xi1 = NUMERIC_POINTER(i1);
	ni1 = LENGTH(i1);

	if (inherits(variable, "interval")) {
		xi = *xi1;
		size = 1;
		rank = 0;
	} else if (inherits(variable, "intervals")) {
		size = ni1;
		rank = 1;
	} else {
		/* intervals2 */
		i2 = VECTOR_ELT(variable, 1);
		xi2 = NUMERIC_POINTER(i2);
		ni2 = LENGTH(i2);
		size = ni1 * ni2;
		rank = 2;
	}


	/* set variable names */
	labels = getAttrib(variable, install("labels"));
	v->names = (void *)R_alloc(size, sizeof(*v->names));
	for (k = 0; k < size; k++) {
		l = STRING_ELT(labels, k);

		if (rank == 2) {
			i = k % ni1;
			j = k / ni1;
			v->names[i * ni2 + j] = CHAR(l);
		} else {
			v->names[k] = CHAR(l);
		}
	}


	/* set type */
	if (inherits(variable, "send")) {
		a = s;
		v->design = VARIABLE_DESIGN_SEND;
		var = &v->var.send;
	} else if (inherits(variable, "actor")) {
		a = r;
		v->design = VARIABLE_DESIGN_RECV;
		var = &v->var.recv;
	} else if (inherits(variable, "dyad")) {
		v->design = VARIABLE_DESIGN_DYAD;
		var2 = &v->var.dyad;
	} else {
		DOMAIN_ERROR("unknown variable type");
	}
	v->type = VARIABLE_TYPE_SPECIAL;


	/* add variable to design */
	if (inherits(variable, "irecvtot")) {
		*var = design_add_tvar(a, NULL, VAR_IRECVTOT, xi);
	} else if (inherits(variable, "isendtot")) {
		*var = design_add_tvar(a, NULL, VAR_ISENDTOT, xi);
	} else if (inherits(variable, "nrecvtot")) {
		*var = design_add_tvar(a, NULL, VAR_NRECVTOT, xi1, ni1);
	} else if (inherits(variable, "nsendtot")) {
		*var = design_add_tvar(a, NULL, VAR_NSENDTOT, xi1, ni1);
	} else if (inherits(variable, "irecv")) {
		*var2 = design2_add_tvar(d, NULL, VAR2_IRECV, xi);
	} else if (inherits(variable, "isend")) {
		*var2 = design2_add_tvar(d, NULL, VAR2_ISEND, xi);
	} else if (inherits(variable, "nrecv")) {
		*var2 = design2_add_tvar(d, NULL, VAR2_NRECV, xi1, ni1);
	} else if (inherits(variable, "nsend")) {
		*var2 = design2_add_tvar(d, NULL, VAR2_NSEND, xi1, ni1);
	} else if (inherits(variable, "nrecv2")) {
		*var2 = design2_add_tvar(d, NULL, VAR2_NRECV2, xi1, ni1, xi2, ni2);
	} else if (inherits(variable, "nsend2")) {
		*var2 = design2_add_tvar(d, NULL, VAR2_NSEND2, xi1, ni1, xi2, ni2);
	} else if (inherits(variable, "nsib")) {
		*var2 = design2_add_tvar(d, NULL, VAR2_NSIB, xi1, ni1, xi2, ni2);
	} else if (inherits(variable, "ncosib")) {
		*var2 = design2_add_tvar(d, NULL, VAR2_NCOSIB, xi1, ni1, xi2, ni2);
	} else {
		DOMAIN_ERROR("unknown variable type");
	}

	return 0;
}
示例#29
0
bool run(const char* config_file, const char* config_arguments, bool sleep_after_init, std::string& app_list)
{
    dsn_core_init();
    ::dsn::task::set_tls_dsn_context(nullptr, nullptr, nullptr);

    dsn_all.engine_ready = false;
    dsn_all.config_completed = false;
    dsn_all.tool = nullptr;
    dsn_all.engine = &::dsn::service_engine::instance();
    dsn_all.config.reset(new ::dsn::configuration());
    dsn_all.memory = nullptr;
    dsn_all.magic = 0xdeadbeef;

    if (!dsn_all.config->load(config_file, config_arguments))
    {
        printf("Fail to load config file %s\n", config_file);
        return false;
    }

    // pause when necessary
    if (dsn_all.config->get_value<bool>("core", "pause_on_start", false,
        "whether to pause at startup time for easier debugging"))
    {
#if defined(_WIN32)
        printf("\nPause for debugging (pid = %d)...\n", static_cast<int>(::GetCurrentProcessId()));
#else
        printf("\nPause for debugging (pid = %d)...\n", static_cast<int>(getpid()));
#endif
        getchar();
    }

    // regiser external app roles by loading all shared libraries
    // so all code and app factories are automatically registered
    dsn::service_spec::load_app_shared_libraries(dsn_all.config);

    for (int i = 0; i <= dsn_task_code_max(); i++)
    {
        dsn_all.task_specs.push_back(::dsn::task_spec::get(i));
    }

    // initialize global specification from config file
    ::dsn::service_spec spec;
    spec.config = dsn_all.config;
    if (!spec.init())
    {
        printf("error in config file %s, exit ...\n", config_file);
        return false;
    }

    dsn_all.config_completed = true;

    // setup data dir
    auto& data_dir = spec.data_dir;
    dassert(!dsn::utils::filesystem::file_exists(data_dir), "%s should not be a file.", data_dir.c_str());
    if (!dsn::utils::filesystem::directory_exists(data_dir.c_str()))
    {
        if (!dsn::utils::filesystem::create_directory(data_dir))
        {
            dassert(false, "Fail to create %s.", data_dir.c_str());
        }
    }
    std::string cdir;
    if (!dsn::utils::filesystem::get_absolute_path(data_dir.c_str(), cdir))
    {
        dassert(false, "Fail to get absolute path from %s.", data_dir.c_str());
    }
    spec.data_dir = cdir;

    // setup coredump dir
    spec.dir_coredump = ::dsn::utils::filesystem::path_combine(cdir, "coredumps");
    dsn::utils::filesystem::create_directory(spec.dir_coredump);
    ::dsn::utils::coredump::init(spec.dir_coredump.c_str());

    // setup log dir
    spec.dir_log = ::dsn::utils::filesystem::path_combine(cdir, "logs");
    dsn::utils::filesystem::create_directory(spec.dir_log);
    
    // init tools
    dsn_all.tool = ::dsn::utils::factory_store< ::dsn::tools::tool_app>::create(spec.tool.c_str(), ::dsn::PROVIDER_TYPE_MAIN, spec.tool.c_str());
    dsn_all.tool->install(spec);

    // init app specs
    if (!spec.init_app_specs())
    {
        printf("error in config file %s, exit ...\n", config_file);
        return false;
    }

    // init tool memory
    dsn_all.memory = ::dsn::utils::factory_store< ::dsn::memory_provider>::create(
        spec.tools_memory_factory_name.c_str(), ::dsn::PROVIDER_TYPE_MAIN);

    // prepare minimum necessary
    ::dsn::service_engine::fast_instance().init_before_toollets(spec);

    // init logging    
    dsn_log_init();

    // init toollets
    for (auto it = spec.toollets.begin(); it != spec.toollets.end(); ++it)
    {
        auto tlet = dsn::tools::internal_use_only::get_toollet(it->c_str(), ::dsn::PROVIDER_TYPE_MAIN);
        dassert(tlet, "toolet not found");
        tlet->install(spec);
    }

    // init provider specific system inits
    dsn::tools::sys_init_before_app_created.execute(::dsn::service_engine::fast_instance().spec().config);

    // TODO: register sys_exit execution

    // init runtime
    ::dsn::service_engine::fast_instance().init_after_toollets();

    dsn_all.engine_ready = true;

    // split app_name and app_index
    std::list<std::string> applistkvs;
    ::dsn::utils::split_args(app_list.c_str(), applistkvs, ';');
    
    // init apps
    for (auto& sp : spec.app_specs)
    {
        if (!sp.run)
            continue;

        bool create_it = false;

        if (app_list == "") // create all apps
        {
            create_it = true;
        }
        else
        {
            for (auto &kv : applistkvs)
            {
                std::list<std::string> argskvs;
                ::dsn::utils::split_args(kv.c_str(), argskvs, '@');
                if (std::string("apps.") + argskvs.front() == sp.config_section)
                {
                    if (argskvs.size() < 2)
                        create_it = true;
                    else
                        create_it = (std::stoi(argskvs.back()) == sp.index);
                    break;
                }
            }
        }

        if (create_it)
        {
            ::dsn::service_engine::fast_instance().start_node(sp);
        }
    }

    if (::dsn::service_engine::fast_instance().get_all_nodes().size() == 0)
    {
        printf("no app are created, usually because \n"
            "app_name is not specified correctly, should be 'xxx' in [apps.xxx]\n"
            "or app_index (1-based) is greater than specified count in config file\n"
            );
        exit(1);
    }
    
    // start cli if necessary
    if (dsn_all.config->get_value<bool>("core", "cli_local", true,
        "whether to enable local command line interface (cli)"))
    {
        ::dsn::command_manager::instance().start_local_cli();
    }

    if (dsn_all.config->get_value<bool>("core", "cli_remote", true,
        "whether to enable remote command line interface (using dsn.cli)"))
    {
        ::dsn::command_manager::instance().start_remote_cli();
    }

    // register local cli commands
    ::dsn::register_command("config-dump",
        "config-dump - dump configuration",
        "config-dump [to-this-config-file]",
        [](const std::vector<std::string>& args)
    {
        std::ostringstream oss;
        std::ofstream off;
        std::ostream* os = &oss;
        if (args.size() > 0)
        {
            off.open(args[0]);
            os = &off;

            oss << "config dump to file " << args[0] << std::endl;
        }

        dsn_all.config->dump(*os);
        return oss.str();
    });
    
    // invoke customized init after apps are created
    dsn::tools::sys_init_after_app_created.execute(::dsn::service_engine::fast_instance().spec().config);

    // start the tool
    dsn_all.tool->run();

    //
    if (sleep_after_init)
    {
        while (true)
        {
            std::this_thread::sleep_for(std::chrono::hours(1));
        }
    }

    // add this to allow mimic app call from this thread.
    memset((void*)&dsn::tls_dsn, 0, sizeof(dsn::tls_dsn));

    return true;
}
示例#30
0
文件: rgeos.c 项目: imclab/rgeos
double getScale(SEXP env) {

    return( NUMERIC_POINTER( findVarInFrame(env, install("scale")) )[0] );
}