1 /* tree_build.c 2008-03-09 */
3 /* Copyright 2008 Emmanuel Paradis */
5 /* This file is part of the R-package `ape'. */
6 /* See the file ../COPYING for licensing issues. */
9 #include <Rinternals.h>
11 static int str2int(char *x, int n)
13 int i, k = 1, ans = 0;
15 for (i = n - 2; i >= 0; i--, k *= 10)
16 ans += ((int)x[i] - 48) * k;
21 void decode_edge(const char *x, int a, int b, int *node, double *w)
24 char *endstr, str[100];
26 while (x[co] != ':') co++;
27 if (a == co) *node = 0;
29 for (i = a, k = 0; i < co; i++, k++) str[k] = x[i];
31 *node = str2int(str, k + 1);
33 for (i = co + 1, k = 0; i <= b; i++, k++) str[k] = x[i];
35 *w = R_strtod(str, &endstr);
38 #define ADD_INTERNAL_EDGE\
40 e[j + nedge] = curnode = ++node;\
43 #define ADD_TERMINAL_EDGE\
45 decode_edge(x, pr + 1, ps - 1, &tmpi, &tmpd);\
52 while (e[l + nedge] != curnode) l--;\
53 decode_edge(x, ps + 1, pt - 1, &tmpi, &tmpd);\
54 nl[curnode - ntip - 1] = tmpi;\
58 SEXP treeBuildWithTokens(SEXP nwk)
61 int n, i, ntip = 1, nnode = 0, nedge, *e, *nl, curnode, node, j, *skeleton, nsk = 0, ps, pr, pt, tmpi, l;
63 SEXP node_label, edge, edge_length, Nnode, phy;
65 PROTECT(nwk = coerceVector(nwk, STRSXP));
66 x = CHAR(STRING_ELT(nwk, 0));
68 skeleton = (int *)R_alloc(n, sizeof(int *));
69 for (i = 0; i < n; i++) {
70 if (x[i] == '(' || x[i] == ',' || x[i] == ')') {
75 case ',': ntip++; break;
76 case ')': nnode++; break;
80 nedge = ntip + nnode - 1;
82 PROTECT(node_label = allocVector(INTSXP, nnode));
83 PROTECT(Nnode = allocVector(INTSXP, 1));
84 PROTECT(edge = allocVector(INTSXP, nedge*2));
85 PROTECT(edge_length = allocVector(REALSXP, nedge));
86 INTEGER(Nnode)[0] = nnode;
88 nl = INTEGER(node_label);
89 memset(nl, 0, nnode*sizeof(int));
91 el = REAL(edge_length);
93 curnode = node = ntip + 1;
96 for (i = 1; i < nsk - 1; i++) {
98 Rprintf(""); /* <- again !!!! */
103 pr = skeleton[i - 1];
106 /* !!! accolades indispensables !!! */
112 pt = skeleton[i + 1];
124 pr = skeleton[nsk - 2];
125 ps = skeleton[nsk - 1];
126 /* is the last edge terminal? */
127 if (x[pr] == ',' && x[ps] == ')') {
131 /* is there a root edge? */
133 PROTECT(phy = allocVector(VECSXP, 5));
135 decode_edge(x, ps + 1, n - 2, &tmpi, &tmpd);
136 PROTECT(root_edge = allocVector(REALSXP, 1));
138 REAL(root_edge)[0] = tmpd;
139 SET_VECTOR_ELT(phy, 4, root_edge);
141 } else PROTECT(phy = allocVector(VECSXP, 4));
143 SET_VECTOR_ELT(phy, 0, edge);
144 SET_VECTOR_ELT(phy, 1, edge_length);
145 SET_VECTOR_ELT(phy, 2, Nnode);
146 SET_VECTOR_ELT(phy, 3, node_label);
152 #undef ADD_INTERNAL_EDGE
153 #undef ADD_TERMINAL_EDGE