The R Project SVN R-packages

Rev

Rev 3821 | Rev 4590 | Go to most recent revision | Show entire file | Ignore whitespace | Details | Blame | Last modification | View Log | RSS feed

Rev 3821 Rev 4160
Line 65... Line 65...
65 
        /* return TRUE; */
 65 
        /* return TRUE; */
66 
    }
 66 
    }
67 
    /* return expanded; */
 67 
    /* return expanded; */
68 
}
 68 
}
69 
 
 69 
 
70 
int _sqlite_error_check(int res, const char *file, int line) {
 70 
R_INLINE int _sqlite_error_check(int res, const char *file, int line) {
71 
    int ret = FALSE;
 71 
    int ret = FALSE;
72 
    if (res != SQLITE_OK) {
72 
    if (res != SQLITE_OK) {
73 
        Rprintf("SQLITE ERROR (line %d at %s): %s\n", line, file, sqlite3_errmsg(g_workspace));
 73 
        Rprintf("SQLITE ERROR (line %d at %s): %s\n", line, file, sqlite3_errmsg(g_workspace));
74 
        ret = TRUE;
 74 
        ret = TRUE;
75 
    }
 75 
    }
Line 181... Line 181...
181 
 
 181 
 
182 
/* return the row names of an sdf as a sqlite.vector */
 182 
/* return the row names of an sdf as a sqlite.vector */
183 
SEXP _get_rownames2(const char *sdf_iname) {
 183 
SEXP _get_rownames2(const char *sdf_iname) {
184 
    int res;
 184 
    int res;
185 
    sqlite3_stmt *stmt;
 185 
    sqlite3_stmt *stmt;
186 
    SEXP ret, value;
 - 
 
187 
    int nprotected = 1;
 - 
 
188 
 
 186 
 
189 
    sprintf(g_sql_buf[2], "select [row name] from [%s].sdf_data", sdf_iname);
 187 
    sprintf(g_sql_buf[2], "select [row name] from [%s].sdf_data", sdf_iname);
190 
    res = sqlite3_prepare(g_workspace, g_sql_buf[2], -1, &stmt, 0);
 188 
    res = sqlite3_prepare(g_workspace, g_sql_buf[2], -1, &stmt, 0);
191 
 
 189 
 
192 
    sqlite3_finalize(stmt);
 190 
    sqlite3_finalize(stmt);
Line 232... Line 230...
232 
    }
 230 
    }
233 
    SET_LEVELS(var, levels);
 231 
    SET_LEVELS(var, levels);
234 
    UNPROTECT(1);
 232 
    UNPROTECT(1);
235 
}
 233 
}
236
234
- 
 
 235 
/* attaches level values and class attributes to the SEXP var if it has class
- 
 
 236 
 * factor and/or ordered */
237 
int _get_factor_levels1(const char *iname, const char *varname, SEXP var) {
 237 
int _get_factor_levels1(const char *iname, const char *varname, SEXP var, int set_class) {
238 
    int res;
 238 
    int res;
- 
 
 239 
    SEXP class;
239
240
240 
    sprintf(g_sql_buf[1], "[%s].[factor %s]", iname, varname);
 241 
    sprintf(g_sql_buf[1], "[%s].[factor %s]", iname, varname);
241 
    res = _get_row_count2(g_sql_buf[1], 0);
 242 
    res = _get_row_count2(g_sql_buf[1], 0);
242 
    if (res > 0) { /* res is exptected to be {-1} \union I+ */
 243 
    if (res > 0) { /* res is exptected to be {-1} \union I+ */
243 
        __attach_levels2(g_sql_buf[1], var, res);
 244 
        __attach_levels2(g_sql_buf[1], var, res);
- 
 
 245 
        if (set_class) {
- 
 
 246 
            PROTECT(class = mkString("factor"));
- 
 
 247 
            SET_CLASS(var, class);
- 
 
 248 
            UNPROTECT(1);
- 
 
 249 
        }
244 
        return VAR_FACTOR;
 250 
        return VAR_FACTOR;
245 
    }
 251 
    }
246 
 
 252 
 
247 
    sprintf(g_sql_buf[1], "[%s].[ordered %s]", iname, varname);
 253 
    sprintf(g_sql_buf[1], "[%s].[ordered %s]", iname, varname);
248 
    res = _get_row_count2(g_sql_buf[1], 0);
 254 
    res = _get_row_count2(g_sql_buf[1], 0);
249 
    if (res > 0) {
 255 
    if (res > 0) {
250 
        __attach_levels2(g_sql_buf[1], var, res);
 256 
        __attach_levels2(g_sql_buf[1], var, res);
- 
 
 257 
        if (set_class) {
- 
 
 258 
            PROTECT(class = NEW_CHARACTER(2));
- 
 
 259 
            SET_STRING_ELT(class, 0, mkChar("ordered"));
- 
 
 260 
            SET_STRING_ELT(class, 1, mkChar("factor"));
- 
 
 261 
            SET_CLASS(var, class);
- 
 
 262 
            UNPROTECT(1);
- 
 
 263 
        }
251 
        return VAR_ORDERED;
 264 
        return VAR_ORDERED;
252 
    }
 265 
    }
253 
 
 266 
 
- 
 
 267 
    /*
- 
 
 268 
    if (set_class) {
- 
 
 269 
        PROTECT(class = NEW_CHARACTER(1));
- 
 
 270 
        SET_STRING_ELT(class, 0, mkChar("integer"));
- 
 
 271 
        SET_CLASS(var, class);
- 
 
 272 
        UNPROTECT(1);
- 
 
 273 
    }*/
- 
 
 274 
 
254 
    return VAR_INTEGER;
 275 
    return VAR_INTEGER;
255 
}
 276 
}
256 
 
 277 
 
257 
SEXP _shrink_vector(SEXP vec, int len) {
 278 
SEXP _shrink_vector(SEXP vec, int len) {
258 
    int origlen = LENGTH(vec);
 279 
    int origlen = LENGTH(vec);
Line 275... Line 296...
275 
            for (i = 0; i < len; i++) REAL(ret)[i] = REAL(vec)[i];
 296 
            for (i = 0; i < len; i++) REAL(ret)[i] = REAL(vec)[i];
276 
        } else if (type == LGLSXP) {
 297 
        } else if (type == LGLSXP) {
277 
            PROTECT(ret = NEW_LOGICAL(len));
 298 
            PROTECT(ret = NEW_LOGICAL(len));
278 
            for (i = 0; i < len; i++) LOGICAL(ret)[i] = LOGICAL(vec)[i];
 299 
            for (i = 0; i < len; i++) LOGICAL(ret)[i] = LOGICAL(vec)[i];
279 
        } else return ret;
 300 
        } else return ret;
- 
 
 301 
 
- 
 
 302 
        /* preserve class, levels for factors/ordered */
- 
 
 303 
        if (isFactor(vec)) {
- 
 
 304 
            SET_CLASS(ret, duplicate(GET_CLASS(vec)));
- 
 
 305 
            SET_LEVELS(ret, duplicate(GET_LEVELS(vec)));
- 
 
 306 
        }
- 
 
 307 
 
280 
        UNPROTECT(1);
 308 
        UNPROTECT(1);
281 
    }
 309 
    }
282 
 
 310 
 
283 
    return ret;
 311 
    return ret;
284 
}
 312 
}