Esempio n. 1
0
SEXP dtrMatrix_as_dtpMatrix(SEXP from)
{
    SEXP val = PROTECT(NEW_OBJECT(MAKE_CLASS("dtpMatrix"))),
	uplo = GET_SLOT(from, Matrix_uploSym),
	diag = GET_SLOT(from, Matrix_diagSym),
	dimP = GET_SLOT(from, Matrix_DimSym);
    int n = *INTEGER(dimP);

    SET_SLOT(val, Matrix_DimSym, duplicate(dimP));
    SET_SLOT(val, Matrix_diagSym, duplicate(diag));
    SET_SLOT(val, Matrix_uploSym, duplicate(uplo));
    full_to_packed_double(
	REAL(ALLOC_SLOT(val, Matrix_xSym, REALSXP, (n*(n+1))/2)),
	REAL(GET_SLOT(from, Matrix_xSym)), n,
	*CHAR(STRING_ELT(uplo, 0)) == 'U' ? UPP : LOW,
	*CHAR(STRING_ELT(diag, 0)) == 'U' ? UNT : NUN);
    SET_SLOT(val, Matrix_DimNamesSym,
	     duplicate(GET_SLOT(from, Matrix_DimNamesSym)));
    UNPROTECT(1);
    return val;
}
Esempio n. 2
0
  String* String::string_dup(STATE) {
    String* ns;

    ns = as<String>(duplicate(state));
    ns->shared(state, Qtrue);
    shared(state, Qtrue);

    // Fix for subclassing
    ns->klass(state, class_object(state));

    return ns;
  }
Esempio n. 3
0
int main (void) {
  /* program to coordinate the menu options and calls the requested function */

  struct node * first = NULL;   /* pointer to the first list item */
  char option[strMax];          /* user response to menu selection */

  printf ("Program to Maintain a List of Names\n");

  while (1) {
    /* print menu options */
    printf ("Options available\n");
    printf ("I - Insert a name (from the keyboard) into the list\n");
    printf ("P - Print the names on the list\n");
    printf ("F - Read a sequence of names from a file onto the list\n");
    printf ("R - Remove duplicate names (leaving only the first occurence)\n");
    printf ("D - Duplicate each node\n");
    printf ("Q - Quit\n");

    /* determine user selection */
    printf ("Enter desired option: ");
    scanf ("%s", option);
    
    switch (option[0])
      { case 'I':
        case 'i': 
          addName(&first);
          break;
        case 'P':
        case 'p': 
          print(first);
          break;
        case 'F':
        case 'f': 
          addNamesFromFile(&first);
          break;
        case 'R':
        case 'r': 
          removeDuplicates(first);
          break;
        case 'D': 
        case 'd': 
          duplicate(first);
          break;
        case 'Q':
        case 'q':
          printf ("Program terminated\n");
          return 0;
          break;
        default: printf ("Invalid Option - Try Again!\n");
          continue;
      }
  }
}
Esempio n. 4
0
    // support for C++ new and delete
    void * MemMgrItf :: _new ( size_t bytes )
    {
        FUNC_ENTRY ();

        // allocate new object plus header size
        Refcount * obj = ( Refcount * ) _alloc ( bytes, true );
        obj -> mmgr = ( MemMgrItf * ) duplicate ();
        obj -> obj_size = bytes;

        // return allocation
        return ( void * ) obj;
    }
Esempio n. 5
0
SEXP attribute_hidden do_args(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP s;

    checkArity(op,args);
    if (TYPEOF(CAR(args)) == STRSXP && length(CAR(args))==1) {
	PROTECT(s = installTrChar(STRING_ELT(CAR(args), 0)));
	SETCAR(args, findFun(s, rho));
	UNPROTECT(1);
    }

    if (TYPEOF(CAR(args)) == CLOSXP) {
	s = allocSExp(CLOSXP);
	SET_FORMALS(s, FORMALS(CAR(args)));
	SET_BODY(s, R_NilValue);
	SET_CLOENV(s, R_GlobalEnv);
	return s;
    }

    if (TYPEOF(CAR(args)) == BUILTINSXP || TYPEOF(CAR(args)) == SPECIALSXP) {
	char *nm = PRIMNAME(CAR(args));
	SEXP env, s2;
	PROTECT_INDEX xp;

	PROTECT_WITH_INDEX(env = findVarInFrame3(R_BaseEnv,
						 install(".ArgsEnv"), TRUE),
			   &xp);

	if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
	PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
	if(s2 != R_UnboundValue) {
	    s = duplicate(s2);
	    SET_CLOENV(s, R_GlobalEnv);
	    UNPROTECT(2);
	    return s;
	}
	UNPROTECT(1); /* s2 */
	REPROTECT(env = findVarInFrame3(R_BaseEnv, install(".GenericArgsEnv"),
					TRUE), xp);
	if (TYPEOF(env) == PROMSXP) REPROTECT(env = eval(env, R_BaseEnv), xp);
	PROTECT(s2 = findVarInFrame3(env, install(nm), TRUE));
	if(s2 != R_UnboundValue) {
	    s = allocSExp(CLOSXP);
	    SET_FORMALS(s, FORMALS(s2));
	    SET_BODY(s, R_NilValue);
	    SET_CLOENV(s, R_GlobalEnv);
	    UNPROTECT(2);
	    return s;
	}
	UNPROTECT(2);
    }
    return R_NilValue;
}
Esempio n. 6
0
SEXP tlocs2rlocs(SEXP tlocs, SEXP exonStarts, SEXP exonEnds,
		SEXP strand, SEXP decreasing_rank_on_minus_strand)
{
	SEXP ans, starts, ends, ans_elt;
	int decreasing_rank_on_minus_strand0, ans_length,
	    i, transcript_width, on_minus_strand, nlocs, j, tloc;

	decreasing_rank_on_minus_strand0 =
		LOGICAL(decreasing_rank_on_minus_strand)[0];
	ans_length = LENGTH(tlocs);
	PROTECT(ans = duplicate(tlocs));
	for (i = 0; i < ans_length; i++) {
		starts = VECTOR_ELT(exonStarts, i);
		ends = VECTOR_ELT(exonEnds, i);
		transcript_width = get_transcript_width(starts, ends, -1);
		if (transcript_width == -1) {
			UNPROTECT(1);
			error("%s", errmsg_buf);
		}
		on_minus_strand = strand_is_minus(strand, i);
		if (on_minus_strand == -1) {
			UNPROTECT(1);
			error("%s", errmsg_buf);
		}
		ans_elt = VECTOR_ELT(ans, i);
		if (ans_elt == R_NilValue) {
			nlocs = 0;
		} else if (IS_INTEGER(ans_elt)) {
			nlocs = LENGTH(ans_elt);
		} else {
			UNPROTECT(1);
			error("'tlocs' has invalid elements");
		}
		for (j = 0; j < nlocs; j++) {
			tloc = INTEGER(ans_elt)[j];
			if (tloc == NA_INTEGER)
				continue;
			if (tloc < 1 || tloc > transcript_width) {
				UNPROTECT(1);
				error("'tlocs[[%d]]' contains \"out of limits\" "
				      "transcript locations (length of "
				      "transcript is %d)", j + 1, transcript_width);
			}
			INTEGER(ans_elt)[j] = tloc2rloc(tloc,
				starts, ends,
				on_minus_strand,
				decreasing_rank_on_minus_strand0);
		}
	}
	UNPROTECT(1);
	return ans;
}
Esempio n. 7
0
/* all, any */
SEXP attribute_hidden do_logic3(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, s, t, call2;
    int narm, has_na = 0;
    /* initialize for behavior on empty vector
       all(logical(0)) -> TRUE
       any(logical(0)) -> FALSE
     */
    Rboolean val = PRIMVAL(op) == _OP_ALL ? TRUE : FALSE;

    PROTECT(args = fixup_NaRm(args));
    PROTECT(call2 = duplicate(call));
    SETCDR(call2, args);

    if (DispatchGroup("Summary", call2, op, args, env, &ans)) {
	UNPROTECT(2);
	return(ans);
    }

    ans = matchArgExact(R_NaRmSymbol, &args);
    narm = asLogical(ans);

    for (s = args; s != R_NilValue; s = CDR(s)) {
	t = CAR(s);
	/* Avoid memory waste from coercing empty inputs, and also
	   avoid warnings with empty lists coming from sapply */
	if(xlength(t) == 0) continue;
	/* coerceVector protects its argument so this actually works
	   just fine */
	if (TYPEOF(t) != LGLSXP) {
	    /* Coercion of integers seems reasonably safe, but for
	       other types it is more often than not an error.
	       One exception is perhaps the result of lapply, but
	       then sapply was often what was intended. */
	    if(TYPEOF(t) != INTSXP)
		warningcall(call,
			    _("coercing argument of type '%s' to logical"),
			    type2char(TYPEOF(t)));
	    t = coerceVector(t, LGLSXP);
	}
	val = checkValues(PRIMVAL(op), narm, LOGICAL(t), XLENGTH(t));
        if (val != NA_LOGICAL) {
            if ((PRIMVAL(op) == _OP_ANY && val)
                || (PRIMVAL(op) == _OP_ALL && !val)) {
                has_na = 0;
                break;
            }
        } else has_na = 1;
    }
    UNPROTECT(2);
    return has_na ? ScalarLogical(NA_LOGICAL) : ScalarLogical(val);
}
Esempio n. 8
0
void read_wifi(struct params *p)
{
	char buf[4096];
	int rc;
	struct ieee80211_frame *wh;

	rc = sniff(p->rx, buf, sizeof(buf));
	if (rc == -1)
		err(1, "sniff()");
        
	wh = get_wifi(buf, &rc);
	if (!wh)
		return;

	/* filter my own shit */
	if (memcmp(wh->i_addr2, p->mac, 6) == 0) {
		/* XXX CTL frames */
		if ((wh->i_fc[0] & IEEE80211_FC0_TYPE_MASK) !=
		    IEEE80211_FC0_TYPE_CTL)
			return;
	}

#if 1
	ack(p, wh);
#endif

	if (duplicate(p, wh, rc)) {
#if 0
		printf("Dup\n");
#endif		
		return;
	}

	switch (wh->i_fc[0] & IEEE80211_FC0_TYPE_MASK) {
	case IEEE80211_FC0_TYPE_MGT:
		read_mgt(p, wh, rc);
		break;
		
	case IEEE80211_FC0_TYPE_CTL:
		read_ctl(p, wh, rc);
		break;
	
	case IEEE80211_FC0_TYPE_DATA:
		read_data(p, wh, rc);
		break;
	
	default:
		printf("wtf\n");
		abort();
		break;
	}
}
Esempio n. 9
0
void duplicate(node* head, node*& newHead)
{
	if(!head)
	{
		newHead = NULL;
		return;
	}

	newHead = new node;
	newHead->data = head->data;
	newHead->previous = head->previous;
	duplicate(head->next, newHead->next);
}
Esempio n. 10
0
SEXP dtrMatrix_addDiag(SEXP x, SEXP d) {
    int n = INTEGER(GET_SLOT(x, Matrix_DimSym))[0];
    SEXP ret = PROTECT(duplicate(x)),
	r_x = GET_SLOT(ret, Matrix_xSym);
    double *dv = REAL(d), *rv = REAL(r_x);

    if ('U' == diag_P(x)[0])
	error(_("cannot add diag() as long as 'diag = \"U\"'"));
    for (int i = 0; i < n; i++) rv[i * (n + 1)] += dv[i];

    UNPROTECT(1);
    return ret;
}
/*------------------------------------嵌入------------------------------------*/
void insert(int s[])
{
    int i;
    srand(time(NULL));
    for(i=1;i<7;i++)
    {
        do
        {
            s[i]=1+rand()%49;
        }
        while(duplicate(s,i));
    }
}
int main () {
	cout<<"\n=====================================\n";
	cout<<"\nProgram to Demonstrate Friend Functions\n";
	cout<<"\n=====================================\n";
	clrscr();
	Rectangle recta, rectb;
	recta.set_values (2,3);
	rectb = duplicate (recta);
	cout <<"\nArea of old Rectangle "<< recta.area();
	cout <<"\nArea of duplicated Rectangle "<< rectb.area();
	getch();
	return 0;
}
Esempio n. 13
0
exprt ranking_synthesis_qbf_bitwiset::instantiate_conjunctive(void)
{
  std::pair<exprt,exprt> dlt = duplicate(affine_template(ID_and, ID_or),
                                         bitwise_width);

  if(bitwise_width<=1)
  {
    dlt.second.negate();
    return binary_relation_exprt(dlt.second, ID_and, dlt.first);
  }
  else
    return binary_relation_exprt(dlt.second, ID_lt, dlt.first);
}
Esempio n. 14
0
/* oldClass<-(), primitive */
SEXP attribute_hidden do_classgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
    checkArity(op, args);
    check1arg(args, call, "x");

    if (NAMED(CAR(args)) == 2) SETCAR(args, duplicate(CAR(args)));
    if (length(CADR(args)) == 0) SETCADR(args, R_NilValue);
    if(IS_S4_OBJECT(CAR(args)))
      UNSET_S4_OBJECT(CAR(args));
    setAttrib(CAR(args), R_ClassSymbol, CADR(args));
    SET_NAMED(CAR(args), 0);
    return CAR(args);
}
Esempio n. 15
0
SEXP do_wcentre(SEXP x, SEXP w)
{
    int nr = nrows(x), nc = ncols(x);
    if (TYPEOF(x) != REALSXP)
	x  = coerceVector(x, REALSXP);
    SEXP rx = PROTECT(duplicate(x));
    if (TYPEOF(x) != REALSXP)
	w = coerceVector(w, REALSXP);
    PROTECT(w);
    wcentre(REAL(rx), REAL(w), &nr, &nc);
    UNPROTECT(2);
    return rx;
}
Esempio n. 16
0
SEXP logit_link(SEXP mu)
{
    int i, n = LENGTH(mu);
    SEXP ans = PROTECT(duplicate(mu));
    double *rans = REAL(ans), *rmu=REAL(mu);

    if (!n || !isReal(mu))
	error(_("Argument %s must be a nonempty numeric vector"), "mu");
    for (i = 0; i < n; i++)
	rans[i] = log(x_d_omx(rmu[i]));
    UNPROTECT(1);
    return ans;
}
ossimConnectableObject* ossimQtIgenController::duplicate(const ossimConnectableObject* obj) const
{
   if(!obj)
   {
      return NULL;
   }

   ossimKeywordlist kwl;
   obj->saveState(kwl);
   ossimObject* tempObj =
      ossimObjectFactoryRegistry::instance()->createObject(kwl);

   if (!tempObj)
   {
      return NULL;
   }
   
   ossimConnectableObject* connectable = PTR_CAST(ossimConnectableObject,
                                                  tempObj);

   if ( !connectable )
   {
      return NULL;
   }

   ossimConnectableContainerInterface* inter =
      PTR_CAST(ossimConnectableContainerInterface, connectable);

   if(inter)
   {
      inter->makeUniqueIds();
   }
   else
   {
      connectable->setId(ossimIdManager::instance()->generateId());
   }
   
   for(ossim_uint32 i = 0; i < obj->getNumberOfInputs(); ++i)
   {
      if(obj->getInput(i))
      {
         ossimConnectableObject* newInput = duplicate(obj->getInput(i));
         if(newInput)
         {
            connectable->connectMyInputTo(newInput);
         }
      }
   }
   
   return connectable;
}
Esempio n. 18
0
/* Computes   x'x  or  x x' -- *also* for Tsparse (triplet = TRUE)
   see Csparse_Csparse_crossprod above for  x'y and x y' */
SEXP Csparse_crossprod(SEXP x, SEXP trans, SEXP triplet)
{
    int trip = asLogical(triplet),
	tr   = asLogical(trans); /* gets reversed because _aat is tcrossprod */
#ifdef AS_CHM_DIAGU2N_FIXED_FINALLY
    CHM_TR cht = trip ? AS_CHM_TR(x) : (CHM_TR) NULL;
#else /* workaround needed:*/
    SEXP xx = PROTECT(Tsparse_diagU2N(x));
    CHM_TR cht = trip ? AS_CHM_TR__(xx) : (CHM_TR) NULL;
#endif
    CHM_SP chcp, chxt,
	chx = (trip ?
	       cholmod_l_triplet_to_sparse(cht, cht->nnz, &c) :
	       AS_CHM_SP(x));
    SEXP dn = PROTECT(allocVector(VECSXP, 2));
    R_CheckStack();

    if (!tr) chxt = cholmod_l_transpose(chx, chx->xtype, &c);
    chcp = cholmod_l_aat((!tr) ? chxt : chx, (int *) NULL, 0, chx->xtype, &c);
    if(!chcp) {
	UNPROTECT(1);
	error(_("Csparse_crossprod(): error return from cholmod_l_aat()"));
    }
    cholmod_l_band_inplace(0, chcp->ncol, chcp->xtype, chcp, &c);
    chcp->stype = 1;
    if (trip) cholmod_l_free_sparse(&chx, &c);
    if (!tr) cholmod_l_free_sparse(&chxt, &c);
    SET_VECTOR_ELT(dn, 0,	/* establish dimnames */
		   duplicate(VECTOR_ELT(GET_SLOT(x, Matrix_DimNamesSym),
					(tr) ? 0 : 1)));
    SET_VECTOR_ELT(dn, 1, duplicate(VECTOR_ELT(dn, 0)));
#ifdef AS_CHM_DIAGU2N_FIXED_FINALLY
    UNPROTECT(1);
#else
    UNPROTECT(2);
#endif
    return chm_sparse_to_SEXP(chcp, 1, 0, 0, "", dn);
}
Esempio n. 19
0
/* duplicate RHS value of complex assignment if necessary to prevent cycles */
INLINE_FUN SEXP R_FixupRHS(SEXP x, SEXP y)
{
    if( y != R_NilValue && MAYBE_REFERENCED(y) ) {
	if (R_cycle_detected(x, y)) {
#ifdef WARNING_ON_CYCLE_DETECT
	    warning("cycle detected");
	    R_cycle_detected(x, y);
#endif
	    y = duplicate(y);
	}
	else if (NAMED(y) < 2) SET_NAMED(y, 2);
    }
    return y;
}
Esempio n. 20
0
void PermutationsII::permute(vector<int>& nums, int head, int tail, vector<vector<int>>& ret)
{
  if (head == tail) {
    ret.push_back(nums);
  } else {
    for (int i = head; i <= tail; i++) {
      if (!duplicate(nums, head, i)) {
        swap(nums[head], nums[i]);
        permute(nums, head + 1, tail, ret);
        swap(nums[head], nums[i]);
      }
    }
  }
}
Esempio n. 21
0
void RowFilter::init()
{
	_comparisons.insert(Comparisons::value_type("<", VALUE_LESS_THAN));
	_comparisons.insert(Comparisons::value_type("<=", VALUE_LESS_THAN_OR_EQUAL));
	_comparisons.insert(Comparisons::value_type("=", VALUE_EQUAL));
	_comparisons.insert(Comparisons::value_type("==", VALUE_EQUAL));
	_comparisons.insert(Comparisons::value_type(">", VALUE_GREATER_THAN));
	_comparisons.insert(Comparisons::value_type(">=", VALUE_GREATER_THAN_OR_EQUAL));
	_comparisons.insert(Comparisons::value_type("<>", VALUE_NOT_EQUAL));
	_comparisons.insert(Comparisons::value_type("!=", VALUE_NOT_EQUAL));
	_comparisons.insert(Comparisons::value_type("IS NULL", VALUE_IS_NULL));

	duplicate();
}
Esempio n. 22
0
int main()
{
   char *p = duplicate("This is a string");

   
   if(p == NULL)
      printf("Duplication failed!\n");
   else
      printf("Duplication worked!\n%s", p);
      
   getchar();
   getchar();
   return 0;
}
void tst_QDeclarativeDebugService::isEnabled()
{
    QDeclarativeDebugTestService service("tst_QDeclarativeDebugService::isEnabled()", m_conn);
    QCOMPARE(service.isEnabled(), false);

    QDeclarativeDebugTestClient client("tst_QDeclarativeDebugService::isEnabled()", m_conn);
    client.setEnabled(true);
    QDeclarativeDebugTest::waitForSignal(&service, SIGNAL(enabledStateChanged()));
    QCOMPARE(service.isEnabled(), true);

    QTest::ignoreMessage(QtWarningMsg, "QDeclarativeDebugService: Conflicting plugin name \"tst_QDeclarativeDebugService::isEnabled()\" ");
    QDeclarativeDebugService duplicate("tst_QDeclarativeDebugService::isEnabled()", m_conn);
    QCOMPARE(duplicate.isEnabled(), false);
}
Esempio n. 24
0
SEXP attribute_hidden R_sysfunction(int n, RCNTXT *cptr)
{
    if (n > 0)
        n = framedepth(cptr) - n;
    else
        n = - n;
    if (n < 0)
        errorcall(R_GlobalContext->call,
                  _("not that many frames on the stack"));
    while (cptr->nextcontext != NULL) {
        if (cptr->callflag & CTXT_FUNCTION ) {
            if (n == 0)
                return duplicate(cptr->callfun);  /***** do we need to DUP? */
            else
                n--;
        }
        cptr = cptr->nextcontext;
    }
    if (n == 0 && cptr->nextcontext == NULL)
        return duplicate(cptr->callfun);  /***** do we need to DUP? */
    errorcall(R_GlobalContext->call, _("not that many frames on the stack"));
    return R_NilValue;	/* just for -Wall */
}
Esempio n. 25
0
	bool execute()
	{
		TaskNotification::execute();

		if (!task()->isCancelled())
		{
			Poco::Clock now;
			_nextExecution += static_cast<Poco::Clock::ClockDiff>(_interval)*1000;
			if (_nextExecution < now) _nextExecution = now;
			queue().enqueueNotification(this, _nextExecution);
			duplicate();
		}
		return true;
	}
Esempio n. 26
0
SEXP Csparse_dense_crossprod(SEXP a, SEXP b)
{
    CHM_SP cha = AS_CHM_SP(a);
    SEXP b_M = PROTECT(mMatrix_as_dgeMatrix(b));
    CHM_DN chb = AS_CHM_DN(b_M);
    CHM_DN chc = cholmod_l_allocate_dense(cha->ncol, chb->ncol, cha->ncol,
					chb->xtype, &c);
    SEXP dn = PROTECT(allocVector(VECSXP, 2)); int nprot = 2;
    double one[] = {1,0}, zero[] = {0,0};
    R_CheckStack();
    // -- see Csparse_dense_prod() above :
    if(cha->xtype == CHOLMOD_PATTERN) {
	SEXP da = PROTECT(nz2Csparse(a, x_double)); nprot++;
	cha = AS_CHM_SP(da);
    }
    cholmod_l_sdmult(cha, 1, one, zero, chb, chc, &c);
    SET_VECTOR_ELT(dn, 0,	/* establish dimnames */
		   duplicate(VECTOR_ELT(GET_SLOT(a, Matrix_DimNamesSym), 1)));
    SET_VECTOR_ELT(dn, 1,
		   duplicate(VECTOR_ELT(GET_SLOT(b_M, Matrix_DimNamesSym), 1)));
    UNPROTECT(nprot);
    return chm_dense_to_SEXP(chc, 1, 0, dn);
}
Esempio n. 27
0
SEXP mvfft(SEXP z, SEXP inverse)
{
    SEXP d;
    int i, inv, maxf, maxp, n, p;
    double *work;
    int *iwork;

    d = getAttrib(z, R_DimSymbol);
    if (d == R_NilValue || length(d) > 2)
	error(_("vector-valued (multivariate) series required"));
    n = INTEGER(d)[0];
    p = INTEGER(d)[1];

    switch(TYPEOF(z)) {
    case INTSXP:
    case LGLSXP:
    case REALSXP:
	z = coerceVector(z, CPLXSXP);
	break;
    case CPLXSXP:
	if (NAMED(z)) z = duplicate(z);
	break;
    default:
	error(_("non-numeric argument"));
    }
    PROTECT(z);

    /* -2 for forward  transform, complex values */
    /* +2 for backward transform, complex values */

    inv = asLogical(inverse);
    if (inv == NA_INTEGER || inv == 0) inv = -2;
    else inv = 2;

    if (n > 1) {
	fft_factor(n, &maxf, &maxp);
	if (maxf == 0)
	    error(_("fft factorization error"));
	work = (double*)R_alloc(4 * maxf, sizeof(double));
	iwork = (int*)R_alloc(maxp, sizeof(int));
	for (i = 0; i < p; i++) {
	    fft_factor(n, &maxf, &maxp);
	    fft_work(&(COMPLEX(z)[i*n].r), &(COMPLEX(z)[i*n].i),
		     1, n, 1, inv, work, iwork);
	}
    }
    UNPROTECT(1);
    return z;
}
/* --- .Call ENTRY POINT --- */
SEXP CompressedIRangesList_gaps(SEXP x, SEXP start, SEXP end)
{
	SEXP ans, ans_names, ans_unlistData,
	     ans_partitioning, ans_partitioning_end;
	cachedCompressedIRangesList cached_x;
	cachedIRanges cached_ir;
	int max_in_length, x_length, start_length, *start_elt, *end_elt, i;
	RangeAE in_ranges, out_ranges;
	IntAE tmpbuf;

	cached_x = _cache_CompressedIRangesList(x);
	max_in_length = get_cachedCompressedIRangesList_max_eltLengths(
				&cached_x);
	in_ranges = _new_RangeAE(0, 0);
	out_ranges = _new_RangeAE(0, 0);
	tmpbuf = _new_IntAE(max_in_length, 0, 0);
	x_length = _get_cachedCompressedIRangesList_length(&cached_x);
	start_length = LENGTH(start);
	if ((start_length != 1 && start_length != x_length) ||
		start_length != LENGTH(end))
        error("'start' and 'end' should both be integer vectors of length 1 or length(x)");
	PROTECT(ans_partitioning_end = NEW_INTEGER(x_length));
	start_elt = INTEGER(start);
	end_elt = INTEGER(end);
	for (i = 0; i < x_length; i++) {
		cached_ir = _get_cachedCompressedIRangesList_elt(&cached_x, i);
		_RangeAE_set_nelt(&in_ranges, 0);
		append_cachedIRanges_to_RangeAE(&in_ranges, &cached_ir);
		_gaps_ranges(in_ranges.start.elts, in_ranges.width.elts,
			_RangeAE_get_nelt(&in_ranges),
			*start_elt, *end_elt,
			tmpbuf.elts, &out_ranges);
		INTEGER(ans_partitioning_end)[i] = _RangeAE_get_nelt(&out_ranges);
		if (start_length != 1) {
			start_elt++;
			end_elt++;
		}
	}
	PROTECT(ans_unlistData = _new_IRanges_from_RangeAE("IRanges",
			&out_ranges));
	PROTECT(ans_names = duplicate(_get_CompressedList_names(x)));
	PROTECT(ans_partitioning = _new_PartitioningByEnd(
			"PartitioningByEnd",
			ans_partitioning_end, ans_names));
	PROTECT(ans = _new_CompressedList(_get_classname(x),
			ans_unlistData, ans_partitioning));
	UNPROTECT(5);
	return ans;
}
Esempio n. 29
0
SEXP smart_network_averaging(SEXP arcs, SEXP nodes, SEXP weights) {

int k = 0, from = 0, to = 0, nrows = LENGTH(arcs) / 2, dims = LENGTH(nodes);
int *a = NULL, *coords = NULL, *poset = NULL;
double *w = NULL;
SEXP weights2, amat, try, acyclic;

  /* allocate and initialize the adjacency matrix. */
  PROTECT(amat = allocMatrix(INTSXP, dims, dims));
  a = INTEGER(amat);
  memset(a, '\0', sizeof(int) * dims * dims);

  /* match the node labels in the arc set. */
  PROTECT(try = match(nodes, arcs, 0));
  coords = INTEGER(try);

  /* duplicate the weights to preserve the oroginal ones. */
  PROTECT(weights2 = duplicate(weights));
  w = REAL(weights2);

  /* sort the strength coefficients. */
  poset = alloc1dcont(nrows);
  for (k = 0; k < nrows; k++)
    poset[k] = k;
  R_qsort_I(w, poset, 1, nrows);

  /* iterate over the arcs in reverse order wrt their strength coefficients. */
  for (k = 0; k < nrows; k++) {

    from = coords[poset[k]] - 1;
    to = coords[poset[k] + nrows] - 1;

    /* add an arc only if it does not introduce cycles. */
    if (!c_has_path(to, from, a, dims, nodes, FALSE, TRUE, FALSE))
      a[CMC(from, to, dims)] = 1;
    else
      warning("arc %s -> %s would introduce cycles in the graph, ignoring.",
        NODE(from), NODE(to));

  }/*FOR*/

  /* convert the adjacency matrix back to an arc set and return it. */
  acyclic = amat2arcs(amat, nodes);

  UNPROTECT(3);

  return acyclic;

}/*SMART_NETWORK_AVERAGING*/
Esempio n. 30
0
SEXP attribute_hidden R_syscall(int n, RCNTXT *cptr)
{
    /* negative n counts back from the current frame */
    /* positive n counts up from the globalEnv */
    SEXP result;

    if (n > 0)
        n = framedepth(cptr) - n;
    else
        n = - n;
    if(n < 0)
        errorcall(R_GlobalContext->call,
                  _("not that many frames on the stack"));
    while (cptr->nextcontext != NULL) {
        if (cptr->callflag & CTXT_FUNCTION ) {
            if (n == 0) {
                PROTECT(result = shallow_duplicate(cptr->call));
                if (cptr->srcref && !isNull(cptr->srcref))
                    setAttrib(result, R_SrcrefSymbol, duplicate(cptr->srcref));
                UNPROTECT(1);
                return result;
            } else
                n--;
        }
        cptr = cptr->nextcontext;
    }
    if (n == 0 && cptr->nextcontext == NULL) {
        PROTECT(result = shallow_duplicate(cptr->call));
        if (cptr->srcref && !isNull(cptr->srcref))
            setAttrib(result, R_SrcrefSymbol, duplicate(cptr->srcref));
        UNPROTECT(1);
        return result;
    }
    errorcall(R_GlobalContext->call, _("not that many frames on the stack"));
    return R_NilValue;	/* just for -Wall */
}