# making a sqlite database
src_sq <- dplyr::src_sqlite("test.sqlite3",create = TRUE)
DBI::dbSendQuery(src_sq$con, "CREATE TABLE table1 (
id integer PRIMARY KEY,
colchar varchar NOT NULL,
colint integer DEFAULT 1,
colreal real,
coldate date,
colbool boolean NOT NULL,
coltimestamp timestamp NOT NULL)
")
DBI::dbSendQuery(src_sq$con, "CREATE TABLE table2 (
id character PRIMARY KEY,
fk integer REFERENCES table1 (id),
colchar varchar,
coltimestamp timestamp NOT NULL)
")
DBI::dbSendQuery(src_sq$con, "CREATE TABLE table3 (
fk_2 character REFERENCES table2 (id),
colreal real DEFAULT 1.008,
coltimestamp timestamp NOT NULL
)")
DBI::dbDisconnect(src_sq$con)
dbfrontendR::createTable(src_sq, "parent", types = c(id = "integer", name = "character(100)", dob = "date"), typePK = "id", typeRequired = c("id", "name"))
dbfrontendR::createTable(src_sq, "child", types = c(id = "integer", name = "character(100)", dob = "date", parent_id = "integer"), typePK = "id", typeRequired = c("id", "name", "parent_id"), typeFK = list(parent_id = "parent"), onUpdate = "cascade", onDelete = "noAction")
RSQLite::dbSendQuery(src_sq$con, "INSERT INTO parent (id, name, dob) VALUES (1, 'suman', '2015-01-01')")
RSQLite::dbSendQuery(src_sq$con, "INSERT INTO parent (id, name, dob) VALUES (2, 'mom', '2015-01-02')")
RSQLite::dbSendQuery(src_sq$con, sql("INSERT INTO parent (id, name, dob) VALUES (3, 'binu', '2015-01-03')"))
RSQLite::dbSendQuery(src_sq$con, build_sql(sql("INSERT INTO "), escape("parent"), sql(" "), escape(c("id", "name", "dob")), sql(" VALUES "), escape(list(8L, "raj", "07-44-2016")),con = src_sq$con))
RSQLite::dbGetQuery(src_sq$con, "SELECT * FROM parent")
db1 <- dbDatabaseClass$new(src_sq, date_input = "ymd", method = "extract_from_db")
# insert data
cols <- db1$get_tables()$parent$get_columns()
cols$name$add_valToDB("sss")
cols$dob$add_valToDB("2015/10/10")
db1$get_tables()$parent$insertIntoDB()
foo <- function(x = c("a", "b")) {
#browser()
x <- match.arg(x,several.ok = TRUE)
return(x)
}
foo <- function(type = c("aa", "xb", "c", "d")) {
type <- match.arg(type)
return(switch(type,
a = 1,
b = 2,
c = ,
d = 0))
}
# running predefined functions on each of the arguments programatically------
foo <- function(a = NULL, b = NULL, c = NULL) {
l_args <- as.list(match.call())
#browser()
if (length(l_args) == 1)
return(NULL)
l_args[1] <- NULL
#browser()
for (i in 1:length(l_args)) {
eval(call(paste0("set_", names(l_args)[i]), l_args[[i]]),envir = e)
}
}
e <- new.env(parent = emptyenv())
e$set_a <- functdemangle( "std::map<std::string,double>" )demangle( "std::map<std::string,double>" )demangle( "std::map<std::string,double>" )ion(a) {
print(paste("a:", a))
}
e$set_b <- function(b) {
print(paste("b:", b))
}
e$set_c <- function(c) {
print(paste("c:", c))
}
# list primary and foreign key constraint ------
#SELECT tc.constraint_name, tc.table_name, kcu.column_name, ccu.table_name AS foreign_table_name, ccu.column_name AS foreign_column_name FROM information_schema.table_constraints AS tc JOIN information_schema.key_column_usage AS kcu ON tc.constraint_name = kcu.constraint_name JOIN information_schema.constraint_column_usage AS ccu ON ccu.constraint_name = tc.constraint_name WHERE constraint_type = 'FOREIGN KEY' AND tc.table_name='mytable';
# list column information -------------------------
# SELECT * FROM INFORMATION_SCHEMA.COLUMNS WHERE table_name = ", dplyr::escape(x))
# check the interdependancy between two classses ---------------------------
class_a <- R6::R6Class("class_a",
public = list(
initialize = function(name) {
self$set_name(name)
},
set_name = function(name) {
private$name <- name
},
get_name = function() {
return(private$name)
}
),
private = list(
name = NULL
)
)
class_b <- R6::R6Class("class_b",
public = list(
make_class_a = function(num = 2) {
#browser()
for (i in 1:num) {
private$classes_a[[i]] <- class_a$new(paste0("classA", i))
print(private$classes_a[[i]])
}
},
get_classes_a = function() {
return(private$classes_a)
}
), private = list(
classes_a = list()
))
print.class_a <- function(obj) {
print(as.character(obj$get_name()))
}
# checking which of the following is faster
df <- data_frame(x = 1:3, y = 3:5)
microbenchmark::microbenchmark(df %>% mutate(z = rep(1, nrow(df))),
df %>% mutate(z = rep(1, length(df$x))))
# making function for partial matching
match_text <- function(text, to_be_matched_against) {
foo <- function(text) {
function(matched_against) {
if (grepl(pattern = matched_against, text)) {
return(TRUE)
} else return(FALSE)
}
}
res <- sapply(to_be_matched_against, foo(text))
return(names(res)[res])
}
# left_join on NULL dataframes
dfx <- data_frame(a = 1:5, b = letters[1:5])
dfy <- data_frame()
bind_rows(dfy, data_frame(a = NA, c = NA))
left_join(dfx, dfy, by = c("a" = "a"))
# getting on update and on delete rules
# information_schema.referential_constraints
## constraint_name
## update_rule, delete_rule
src <- src_postgres(dbname = "patient_hemat",user = "mom",password = "docpapu2001")
sSQL1 <- "SELECT tc.constraint_name, tc.table_name, kcu.column_name, ccu.table_name AS foreign_table_name, ccu.column_name AS foreign_column_name FROM information_schema.table_constraints AS tc JOIN information_schema.key_column_usage AS kcu ON tc.constraint_name = kcu.constraint_name JOIN information_schema.constraint_column_usage AS ccu ON ccu.constraint_name = tc.constraint_name WHERE constraint_type = "
sSQL1 <- "SELECT tc.constraint_name, tc.table_name, kcu.column_name, ccu.table_name AS foreign_table_name, ccu.column_name AS foreign_column_name, rc.update_rule As update_rule, rc.delete_rule AS delete_rule FROM information_schema.table_constraints AS tc JOIN information_schema.key_column_usage AS kcu ON tc.constraint_name = kcu.constraint_name JOIN information_schema.constraint_column_usage AS ccu ON ccu.constraint_name = tc.constraint_name JOIN information_schema.referential_constraints AS rc ON rc.constraint_name = tc.constraint_name WHERE constraint_type = "
sSQL2 <- " AND tc.table_name = "
tbls <- db_list_tables(src$con)
for (i in tbls) {
print(RPostgreSQL::dbGetQuery(src$con, paste0(sSQL1, dplyr::escape("FOREIGN KEY"), sSQL2, dplyr::escape(i))))
cat("\n\n")
}
# understanding date formatting
x <- "2015/09/08"
is.Date(x)
is.Date(ymd(x))
as.Date(35, origin= "2015/09/09") #format = "%d/%m/%Y")
# check speed of various method dispatch system
class_cpos <- R6::R6Class(classname = "class_a1",
public = list(
initialize = function(name) {
self$set_name(name)
},
set_name = function(name) {
private$name <- name
},
get_name = function() {
return(private$name)
},
print = function() {
foo(private$name)
}
),
private = list(
name = NULL
)
)
class_cneg <- R6::R6Class(classname = NULL,
public = list(
initialize = function(name) {
self$set_name(name)
},
set_name = function(name) {
private$name <- name
},
get_name = function() {
return(private$name)
},
print = function() {
foo(private$name)
}
),
private = list(
name = NULL
)
)
print.class_a1 <- function(obj) {
return(paste0("my name is ", obj$get_name()))
}
foo <- function(x) {
return(paste0("my name is ", x))
}
cl1 <- class_cpos$new("suman")
cl2 <- class_cneg$new("suman")
microbenchmark::microbenchmark(cl1$print(),
cl2$print(),
print(cl1))
# make function to INSERT data into database. It will be called from table class
prepare_cols_for_insertion <- function(src, table) {
cols <- table$get_nameColumns()
vals <- setNames(vector("list", length(cols)), cols)
for (i in cols) {
coli <- table$get_columns()[[i]]
# check for PK
if (coli$isPK() == 1) {
vals[[i]] <- insert_pk_val(src, coli)
next()
}
# check for FK
if (coli$isFK() == 1) {
check_fk_val(src, coli)
}
# check for NULL field
check_for_nothing(coli)
vals[[i]] <- coli$get_valToDB()
}
vals <- lapply(vals, function(x) {
if (is.null(x) | (is.na(x))) {
x <- NULL
}
})
return(vals)
}
## make INSERT COLUMN
insert_into_table <- function(list_col_val) {
cols <- names(list_col_val)
col_str <- paste0("(", paste0(dplyr::escape(cols), collapse = ", "), ")")
# the prototype
# RSQLite::dbSendQuery(src_sq$con, build_sql(sql("INSERT INTO "), escape("parent"), sql(" "), escape(c("id", "name", "dob")), sql(" VALUES "), escape(list(8L, "raj", "07-44-2016")),con = src_sq$con))
}
## insert PK
insert_pk_val <- function(src, col) {
if (col$get_typeData() == "integer") {
pkVals <- dplyr::collect(dplyr::tbl(src, col$get_nameTable()) %>% dplyr::select_(.dots = col$get_name()))[[col$get_name()]]
val <- nextNumber(pkVals)
} else {
val <- uid()
}
col$set_PKNextVal(val)
return(val)
}
dplyr::build_sql(dplyr::sql("PRAGMA table_info("), dplyr::escape(tbl_name), dplyr::sql(")"))
## insert FK
check_fk_val <- function(src, col) {
refTable <- col$get_refTable()
refCol <- col$get_refCol()
poss_vals <- dplyr::collect(dplyr::tbl(src, refTable) %>% dplyr::select_(.dots = refCol))
if (!(col$get_valToDB() %in% poss_vals[[refCol]]))
stop(paste0("Value of ", col$get_valToDB(), " to be added to ", col$get_name(), " is not contained in PK: ", refTable, "-", refCol))
invisible(NULL)
}
## check for columns with no values with isRequired and delete the columns if required
check_for_nothing <- function(col) {
isnull <- is.null(col$get_valToDB())
isna <- is.na(col$get_valToDB())
defaultVal <- col$get_defaultVal()
is_default_available <- !(is.null(defaultVal) | is.na(defaultVal) | defaultVal == "")
isreqd <- (col$get_isRequired() == 1)
is_val_nothing <- (isnull | isna)
if (is_val_nothing && isreqd) {
if (!is_default_available) {
stop(paste0("No value is available for ", col$get_name(), " of ", col$get_nameTable()))
}
}
invisible(NULL)
}
## formatting with data type already checked at the time of data entry into add_ValToDB
## validation mechanism
a <- R6::R6Class("a", public = list(
initialize = function(name) {
private$name <- name
invisible(self)
},
add_val = function(val) {
# add validation statement
#browser()
val_res <- validate(val, private$val_statement)
if (val_res$result) {
private$val <- val
} else {
stop(val_res$err_msg, call. = FALSE)
}
invisible(self)
},
validation_statement = function(...) {
private$val_statement <- lazyeval::lazy_dots(...)
},
get_val = function() {
return(private$val)
}),
private = list(
name = NULL,
val = NULL,
val_statement = NULL))
validate <- function(val, condition) {
validate_result <- vapply(condition, function(x) {
res <- lazyeval::lazy_eval(x, data = list(`..` = val))
res
}, logical(1L))
err_msg <- paste0("<VALIDATION FAILURE FOR RULE(S)> ", paste0(vapply(condition[!validate_result], function(x) deparse(lazyeval::interp(x[["expr"]], .values = list(`..` = val))), character(1L)), collapse = "; "))
return(list(result = all(validate_result), err_msg = err_msg))
}
b <- 10
cl_a <- a$new("suman")
cl_a$validation_statement(is.character(..))
cl_a$add_val("suman")
# make an error handler for errors raised from database. It will return a false and error number and error msg
err_from_db <- function(src, expr, env = parent.env()) {
q_expr <- lazyeval::lazy(expr, env = env)
res <- try(lazyeval::lazy_eval(q_expr), silent = TRUE)
db_error <- DBI::dbGetException(src$con)
if (inherits(res, "try-error") && !is.null(db_error)) {
is_err <- TRUE
err_no <- db_error$errorNum
err_msg <- db_error$errorMsg
} else {
is_err <- FALSE
err_no <- NULL
err_msg <- NULL
}
return(list(is_err = is_err, err_no = err_no, err_msg = err_msg))
}
default_val <- function(expr = NULL) {
lazyeval::lazy(expr)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.