MINI MINI MANI MO
Rem
Rem Copyright (c) 2011, 2017, Oracle and/or its affiliates.
Rem All rights reserved.
Rem
Rem NAME
Rem rqcrt.sql - RQuery CReaTe rqsys schema
Rem
Rem DESCRIPTION
Rem Creates an RQSYS schema.
Rem
Rem NOTES
Rem The script takes the following parameters:
Rem arg1 - RQSYS Schema Password
Rem arg2 - default tablespace (SYSAUX)
Rem arg3 - tempopary tablespace (TEMP)
Rem
Rem MODIFIED (MM/DD/YY)
Rem qinwan 03/03/17 - rollback to session_user on rq_scripts
Rem qinwan 10/07/16 - change session_user to current_user
Rem lbzhang 06/01/16 - Bug23512913 single predictor error in RF build
Rem ffeli 02/18/16 - ORE 1.5.1 upgrade
Rem lbzhang 09/08/15 - add randomForest embedded R functions
Rem qinwan 08/22/15 - update rq$script constraint name
Rem ffeli 06/08/15 - Add owner attribute to rq$script table
Rem lbzhang 12/30/14 - add svd embedded R function definitions
Rem lbzhang 12/12/14 - ORE 1.5
Rem demukhin 07/13/14 - split configuration into a separate step
Rem piyussin 01/17/14 - Removed SUPP_LIB_PATH
Rem lzhang 12/18/13 - add RQ$ESM_FITTED
Rem lzhang 12/06/13 - add ordering of df in RQ$ESM_SEQ
Rem paboyoun 11/19/13 - add a finalizer to glm reducer
Rem paboyoun 11/01/13 - increase MIN_NSIZE in rq$config from 1M to 2M
Rem piyussin 10/25/13 - add SUPP_LIB_PATH to rq$config
Rem piyussin 10/17/13 - add the RQSYS password parameter
Rem paboyoun 10/12/13 - fix RQ.installed.packages when package is
Rem installed in multiple locations
Rem lzhang 10/04/13 - add RQ$ESM_* objective functions
Rem paboyoun 10/04/13 - pull elements individually during ore.glm
Rem reduction
Rem paboyoun 09/25/13 - add RQ$GLM_LINE_SEARCH
Rem paboyoun 08/20/13 - move glm functions to OREmodels
Rem paboyoun 08/06/13 - rename RQ$GLM_FIT_MAPPER
Rem paboyoun 07/09/13 - add scripts for ore.stepwise
Rem dgolovas 03/29/13 - neural network prediction
Rem demukhin 03/22/13 - bug 16536750: missing grants when upgrading 1.1
Rem qinwan 11/02/12 - predefined R/package version script
Rem qinwan 10/16/12 - raise min R memory limits for R-2.15
Rem demukhin 10/03/12 - prj: no roles
Rem qinwan 09/18/12 - add memory limit control
Rem demukhin 08/30/12 - prj: BLOB image
Rem demukhin 08/29/12 - ORE version 1.3
Rem demukhin 07/13/12 - ORE version 1.2
Rem mhornick 07/06/12 - add 'create mining model' priv to rqrole
Rem paboyoun 04/24/12 - add script for fitdistr
Rem schakrab 04/11/12 - fix bug 13631447
Rem demukhin 03/19/12 - add VERSION
Rem demukhin 01/17/12 - add R_HOME config option
Rem demukhin 12/07/11 - named script support
Rem demukhin 12/05/11 - embedded layer security review changes
Rem demukhin 11/22/11 - password expire; account lock
Rem demukhin 09/27/11 - Created
Rem
--***************************************************************************--
--* (*) USER *--
--***************************************************************************--
create user rqsys identified by &&1
default tablespace &&2
temporary tablespace &&3
quota 250M on &&2
PASSWORD EXPIRE
account lock;
--***************************************************************************--
--* (*) ROLES *--
--***************************************************************************--
-- user role (deprecated)
--
create role rqrole;
-- admin role
--
create role rqadmin;
--***************************************************************************--
--* (*) R SCRIPTS *--
--***************************************************************************--
create table rq$script(
owner varchar2(128) default 'RQSYS',
name varchar2(128),
script clob,
constraint rq$script_pk primary key (owner, name));
-- predifined ESM script-------------------------------------------------------
insert into rq$script (name, script) values ('RQ$ESM_SIMPLE_INIT',
'function(df, alpha, lpt, num.chunk)
{
grpIdx <- df$GRPIDX[1L]
# the last chunk
if (grpIdx == num.chunk-1)
return(data.frame(SUM=0, FIRST=df[1L,2L], GRPIDX =grpIdx))
# nr is supposed to be equal to lpt, but if the input ID col is datetime,
# and the ts is not evenly spaced (not aggregated), nr is not equal to lpt,
# and thus, it will generate weird results, this should be improved later.
nr = nrow(df)
library(OREserver)
temp <- .Call("ORE_TS_simpleESM_init", df, alpha, nr, PACKAGE="OREserver")
data.frame(SUM=temp, FIRST=df[1L,2L], GRPIDX=grpIdx)
}');
insert into rq$script (name, script) values ('RQ$ESM_SIMPLE',
'function(df, S.init, alpha)
{
grpIdx <- df$GRPIDX[1L]
nr <- nrow(df)
library(OREserver)
err.vec <- .Call("ORE_TS_simpleESM", df, S.init, alpha, nr, 1L,
PACKAGE="OREserver")
data.frame(ERR=err.vec[1], LASTS = err.vec[2], GRPIDX = grpIdx)
}');
insert into rq$script (name, script) values ('RQ$ESM_DOUBLE_INIT',
'function(df, alpha, beta, lpt, num.chunk)
{
grpIdx <- df$GRPIDX[1L]
out.name <- c(rep("S",num.chunk), rep("b",num.chunk))
# the last chunk
if (grpIdx == num.chunk-1)
{
out.vec.S <- vector(length = num.chunk, mode = "numeric")
out.vec.b <- vector(length = num.chunk, mode = "numeric")
if (num.chunk > 1)
{
out.vec.S[num.chunk] <- alpha*df[1L, 2L]
out.vec.b[num.chunk] <- alpha*beta*df[1L, 2L]
}
else # the case of DOP==1
{
out.vec.S[1] <- df[1L, 2L]
out.vec.b[1] <- df[2L, 2L] - df[1L, 2L]
}
return(data.frame(VAL=c(out.vec.S, out.vec.b),
NAME = out.name, GRPIDX =grpIdx, SIDX = rep(seq_len(num.chunk),2L)))
}
# nr is supposed to be equal to lpt, but if the input ID col is datetime,
# and the ts is not evenly spaced (not aggregated), nr is not equal to lpt,
# and thus, it will generate weird results, this should be improved later.
nr = nrow(df)
library(OREserver)
temp.matrix <- .Call("ORE_TS_doubleESM_init", df, alpha, beta, nr,
num.chunk, PACKAGE="OREserver")
data.frame(VAL=as.vector(temp.matrix[,1L:2L]),
NAME = out.name, GRPIDX =grpIdx, SIDX = rep(seq_len(num.chunk),2L))
}');
insert into rq$script (name, script) values ('RQ$ESM_DOUBLE',
'function(df, S.init, b.init, alpha, beta)
{
grpIdx <- df$GRPIDX[1L]
nr <- nrow(df)
library(OREserver)
err.vec <- .Call("ORE_TS_doubleESM", df, S.init, b.init, alpha, beta, nr, 1L, PACKAGE="OREserver")
data.frame(ERR = err.vec[1L], LASTS = err.vec[2L], LASTB = err.vec[3L],
FIRSTX = df[1L, 2L], GRPIDX=grpIdx)
}');
insert into rq$script (name, script) values ('RQ$ESM_SEQ',
'function(df, model, N, optim.start, optim.control)
{
library(OREserver)
df <- df[order(df[[1L]]), , drop = FALSE]
.ore.sESM.obj.seq <- function(ts, alpha, nr, optimization=TRUE)
{
S.init <- ts[1L, 2L]
err.vec <- .Call("ORE_TS_simpleESM", ts, S.init, alpha, nr, 0L,
PACKAGE="OREserver")
if (optimization)
err.vec[1L]
else
err.vec[2L]
}
.ore.dESM.obj.seq <- function(ts, alpha, beta, nr,
optimization=TRUE)
{
S.init <- ts[1L, 2L]
b.init <- ts[2L, 2L] - ts[1L, 2L]
err.vec <- .Call("ORE_TS_doubleESM", ts, S.init, b.init,
alpha, beta, nr, 0L, PACKAGE="OREserver")
if (optimization)
err.vec[1L]
else
err.vec[2L:3L]
}
if (model == "SIMPLE")
{
error.fun <- function(p) .ore.sESM.obj.seq(df, p, as.integer(N))
res <- optimize(error.fun, lower = 0, upper = 1)
alpha <- res$minimum
res$last.S <- .ore.sESM.obj.seq(df, alpha, as.integer(N), FALSE)
}
else if (model == "DOUBLE")
{
error.fun <- function(p)
.ore.dESM.obj.seq(df, p[1L], p[2L], as.integer(N))
res <- optim(optim.start, error.fun, method = "L-BFGS-B",
lower = c(0, 0), upper = c(1, 1), control = optim.control)
alpha <- res$par[1L]
beta <- res$par[2L]
res$last.SB <- .ore.dESM.obj.seq(df, alpha, beta, as.integer(N),
FALSE)
}
res
}');
insert into rq$script (name, script) values ('RQ$ESM_FITTED',
'function(df, model, smoothing.param, begin, end)
{
# sort df, unnecessary after ore.tableApply is changed to respect the
# ordering of ore.frame
df = df[order(df[[1L]]), , drop = FALSE]
if (model == "SIMPLE")
{
alpha <- as.numeric(smoothing.param)
St <- vector(length=(end-begin+1L), mode="numeric")
S.temp <- df[1L, 2L]
if (begin == 1L)
{
index = 1L
St[index] <- S.temp
}
if (end >= 2L)
{
for (i.row in 2L:end)
{
S.temp <- alpha*df[i.row-1L, 2L] + (1-alpha)*S.temp
if(i.row == begin)
{
index = 1L
St[index] <- S.temp
}
else if (i.row > begin)
{
index = index + 1L
St[index] <- S.temp
}
}
}
}
else if (model == "DOUBLE")
{
alpha <- as.numeric(smoothing.param[1L])
beta <- as.numeric(smoothing.param[2L])
St <- vector(length=(end-begin+1L), mode="numeric")
St.temp <- df[1L, 2L]
if (begin == 1L)
{
index = 1L
St[index] <- St.temp
}
S.pre <- df[1L, 2L]
b.pre <- df[2L, 2L] - df[1L, 2L]
if (end >= 2L)
{
for (i.row in 2L:end)
{
St.temp <- S.pre + b.pre
S <- alpha*df[i.row, 2L] + (1-alpha)*St.temp
b.pre <- beta*(S-S.pre) + (1-beta)*b.pre
S.pre <- S
if (i.row == begin)
{
index = 1L
St[index] <- St.temp
}
else if (i.row > begin)
{
index = index + 1L
St[index] <- St.temp
}
}
}
}
data.frame(ID=1:(end-begin+1L), VAL=St)
}');
-- predefined R scripts -------------------------------------------------------
--
insert into rq$script (name, script) values ('RQ$FITDISTR',
'function(x, densfun, start, ...)
{
# construct hopefully unique id
id <- sprintf("%s:%s:%s", Sys.getpid(),
(1000 * proc.time()[3L]) %% 2147483647,
sample.int(32767L, 1L))
# fit distribution
require(MASS)
if (missing(start))
x <- fitdistr(x, densfun, ...)
else
x <- fitdistr(x, densfun, start, ...)
k <- length(x$estimate)
rbind(data.frame(id = id,
element = "estimate",
position = seq_len(k),
name1 = names(x$estimate),
name2 = NA_character_,
value = unname(x$estimate),
stringsAsFactors = FALSE),
data.frame(id = id,
element = "sd",
position = seq_len(k),
name1 = names(x$sd),
name2 = NA_character_,
value = unname(x$sd),
stringsAsFactors = FALSE),
data.frame(id = id,
element = "vcov",
position = seq_len(length(x$vcov)),
name1 = rep(rownames(x$vcov), k),
name2 = rep(colnames(x$vcov), each = k),
value = c(x$vcov),
stringsAsFactors = FALSE),
data.frame(id = c(id, id),
element = c("loglik", "n"),
position = c(NA_integer_, NA_integer_),
name1 = c(NA_character_, NA_character_),
name2 = c(NA_character_, NA_character_),
value = c(x$loglik, x$n),
stringsAsFactors = FALSE))
}');
-- generalized linear model ---------------------------------------------------
--
insert into rq$script (name, script) values ('RQ$GLM_FIT_MAPPER',
'function(..., sparse = FALSE)
{
ans <- OREserver:::.ore.glm.fitmapper(..., sparse = sparse)
if (exists(".ore.combined.output", envir=.GlobalEnv, inherits=FALSE))
{
ctime <- proc.time()[[3L]]
old <- get(".ore.combined.output", envir=.GlobalEnv, inherits=FALSE)
ans <- OREserver:::.ore.glm.fitreducer(old, ans, sparse = sparse)
ctime <- proc.time()[[3L]] - ctime
ans$comb_time <- old$comb_time + ctime
ans$comb_time_sq <- old$comb_time_sq + (ctime * ctime)
}
assign(".ore.combined.output", ans, envir=.GlobalEnv)
structure(list(), class = "ore-using-combiner")
}');
insert into rq$script (name, script) values ('RQ$GLM_FIT_REDUCER',
'function(blockobj, ..., sparse = FALSE, stepwise = FALSE, stats = TRUE)
{
k <- length(blockobj)
ans <- blockobj[[1L]]
if (k > 1L)
{
if ((k <= 4L) || (k * object.size(ans) > 1024^3))
for (i in 2L:k)
ans <-
OREserver:::.ore.glm.fitreducer(ans, blockobj[[i]], sparse = sparse)
else
ans <-
Reduce(function(e1, e2)
OREserver:::.ore.glm.fitreducer(e1, e2, sparse = sparse),
OREbase::ore.pull(blockobj))
}
if (is.null(ans$pivot))
{
if (stats)
ans <- OREserver:::.ore.glm.fitcholesky(ans, sparse = sparse)
else
ans <- OREserver:::.ore.glm.fitcoefficients(ans, sparse = sparse)
}
else
ans <- OREserver:::.ore.glm.fitqr(ans, sparse = sparse)
if (stepwise)
ans <- OREserver:::.ore.glm.stepwise(ans, ...)
if (stats)
OREserver:::.ore.glm.fitstats(ans, sparse = sparse)
else
ans
}');
insert into rq$script (name, script) values ('RQ$GLM_LINE_SEARCH',
'function(...)
{
ans <- OREserver:::.ore.glm.linesearchmapper(...)
if (exists(".ore.combined.output", envir=.GlobalEnv, inherits=FALSE))
{
ctime <- proc.time()[[3L]]
old <- get(".ore.combined.output", envir=.GlobalEnv, inherits=FALSE)
ans[[2L]] <- old[[2L]] + ans[[2L]]
comb <- which(ans[[2L]] == -5)
comb_sq <- which(ans[[2L]] == -6)
ctime <- proc.time()[[3L]] - ctime
ans[[2L]][comb] <- ans[[2L]][comb] + ctime
ans[[2L]][comb_sq] <- ans[[2L]][comb_sq] + (ctime * ctime)
}
assign(".ore.combined.output", ans, envir=.GlobalEnv)
structure(list(), class = "ore-using-combiner")
}');
-- predefined Neural Network scripts: Training --------------------------------
--
insert into rq$script (name, script) values ('RQ$NEURAL',
'function(data, param, weight) {
if (param$isSimpleFormula) {
target <- as.numeric(data[[1L]])
} else {
target <- model.response(model.frame(param$formula, data=data,
xlev=param$xlev), type="numeric")
}
mMatrix <- OREserver:::.ore.neural.model.matrix(param$origFormula,
param$isSimpleFormula, data, param$sparse, param$xlev)
.Call("oreNeural", param, mMatrix, target, weight, PACKAGE="OREserver")
}');
-- predefined Neural Network scripts: OOC OBJ ---------------------------------
--
insert into rq$script (name, script) values ('RQ$NEURALOBJ',
'function(data, param, weight) {
if (param$isSimpleFormula) {
target <- as.numeric(data[[1L]])
} else {
target <- model.response(model.frame(param$formula, data=data,
xlev=param$xlev), type="numeric")
}
mMatrix <- OREserver:::.ore.neural.model.matrix(param$origFormula,
param$isSimpleFormula, data, param$sparse, param$xlev)
ans <- .Call("oreNeuralObjWorker", param, mMatrix, target, weight,
PACKAGE="OREserver")
if (exists(".ore.combined.output", envir=.GlobalEnv, inherits=FALSE)) {
old <- get(".ore.combined.output", envir=.GlobalEnv, inherits=FALSE)
ans[[2L]] <- old[[2L]] + ans[[2L]]
}
assign(".ore.combined.output", ans, envir=.GlobalEnv)
structure(list(), class = "ore-using-combiner")
}');
-- predefined Neural Network scripts: Prediction ------------------------------
--
insert into rq$script (name, script) values ('RQ$NEUPRED',
'function(data, param, supplemental.cols) {
if (options("na.action") != "na.pass") options(na.action="na.pass")
if (param$sparse) {
require(Matrix, quietly=TRUE)
colMatrix <- sparse.model.matrix(param$explanatory, data=data,
xlev=param$xlev)
colMatrix <- colMatrix[,-1L]
if (is.numeric(colMatrix)) colMatrix <- as.matrix(colMatrix, ncol=1L)
modMatrix <- as(colMatrix, "RsparseMatrix")
rm(colMatrix)
} else {
modMatrix <- model.matrix(param$explanatory, data=data, xlev=param$xlev)
}
nRows <- nrow(modMatrix)
if (!is.null(supplemental.cols)) {
Y <- cbind(data[supplemental.cols], PREDICTION=rep.int(0.0, nRows))
} else {
Y <- data.frame(PREDICTION=rep.int(0.0, nRows))
}
.Call("neuralPredict", param, modMatrix, param$weight, Y$PREDICTION,
PACKAGE="OREserver")
Y
}');
commit;
-- randomForest ---------------------------------------------------------------
--
insert into rq$script (name, script) values ('RQ$RF_PIDCHK',
'function(df) {
data.frame(idx = df[1], pid = Sys.getpid())
}');
insert into rq$script (name, script) values ('RQ$RF_GETTREE',
'function(object, k, labelVar)
{
object <- unserialize(object)
if (object$RFOPKG)
{
if(!requireNamespace("RFO", quietly = TRUE))
stop("Oracle R Distribution (ORD 3.2 or higher) is not running at ORE server")
funName <- RFO::getTree
}
else
{
if(!requireNamespace("randomForest", quietly = TRUE))
stop("randomForest package is not installed at ORE server")
funName <- randomForest::getTree
}
ntrees <- object$ntrees
l <- length(ntrees)
countTrees <- sapply(1:l, function(idx) sum(ntrees[1:idx]))
idxForest <- which(! k > countTrees)[1L]
if (idxForest > 1L)
idxTree <- k - countTrees[idxForest - 1L]
else
idxTree <- k
rfMod <- ore.pull(object$forest[object$forest$ID==idxForest, 2L:3L])
rfMod <- OREcommon:::.ore.unserialize(rfMod$VALUE[order(rfMod$CHUNK)])
tree <- as.data.frame(do.call(funName, list(rfMod, idxTree, labelVar)))
cbind(data.frame("node id" = seq(nrow(tree))), tree)
}');
insert into rq$script (name, script) values ('RQ$RF_BUILD',
'function(df, data.s, mtry, replace, classwt, cutoff, sampsize, nodesize,
maxnodes, rand.seed, na.action, rfFlag, singleChunk)
{
ntree <- df[1L, 1L]
idx <- df[1L, 2L]
set.seed(idx + rand.seed)
if (exists("rf.data.cache", envir=.GlobalEnv, inherits=FALSE))
data <- get("rf.data.cache", envir=.GlobalEnv, inherits=FALSE)
else
{
data <- ore.pull(unserialize(data.s))
data[, 1L] <- as.factor(data[, 1L])
if (is.logical(singleChunk))
{
if (!singleChunk[idx])
assign("rf.data.cache", data, envir=.GlobalEnv)
}
}
if (!(rfFlag || !requireNamespace("RFO", quietly = TRUE)))
{
RFOPKG <- TRUE
funName <- RFO:::randomForest.default
}
else
{
if(!requireNamespace("randomForest", quietly = TRUE))
stop("ore.randomForest requires either Oracle R Distribution 3.2 or higher (preferable) or open source R randomForest (>= 4.6-10) package installed at ORE server")
RFOPKG <- FALSE
funName <- randomForest:::randomForest.default
if(any(is.na(data))) data <- na.action(data)
}
argList <- list(x = quote(data[, 2L : ncol(data), drop = FALSE]),
y = quote(data[, 1L]),
ntree = quote(ntree),
mtry = quote(mtry),
replace = quote(replace),
classwt = quote(classwt),
sampsize = quote(sampsize),
nodesize = quote(nodesize),
maxnodes = quote(maxnodes),
na.action = quote(na.action))
if (!is.null(cutoff))
argList$cutoff <- cutoff
mod <- do.call(funName, argList)
mod <- OREcommon:::.ore.serialize(mod, chunksize = 2000L)
gc()
ret <- data.frame(ID = c(0L, rep(idx, nrow(mod))), CHUNK = c(0L, mod$CHUNK))
ret$VALUE <- c(list(as.raw(RFOPKG)), mod$VALUE)
ret
}');
insert into rq$script (name, script) values ('RQ$RF_SCORE',
'function(df, modObj, classes, type, norm.votes, sup.cols,
cache.model, RFOPKG, singleChunk)
{
grpID <- df[1L, "OREGRPID"]
df[["OREGRPID"]] <- NULL
for(icol in 1L:ncol(df))
if (is.character(df[, icol])) df[, icol] <- as.factor(df[, icol])
N <- nrow(df)
if (cache.model)
{
if (exists("rf.mod.cache", envir=.GlobalEnv, inherits=FALSE))
{
mod <- get("rf.mod.cache", envir=.GlobalEnv, inherits=FALSE)
num.mod <- length(mod)
}
else if (!(!is.logical(singleChunk) || !singleChunk[grpID]))
cache.model <- FALSE
else
{
modObj <- unserialize(modObj)
mod <- ore.pull(modObj)
mod <- lapply(split(mod, mod$ID),
function(m)
OREcommon:::.ore.unserialize(m$VALUE[order(m$CHUNK)]))
assign("rf.mod.cache", mod, envir=.GlobalEnv)
num.mod <- length(mod)
gc()
}
}
if (!cache.model)
{
modObj <- unserialize(modObj)
if (exists("rf.num.mod.cache", envir=.GlobalEnv, inherits=FALSE))
num.mod <- get("rf.num.mod.cache", envir=.GlobalEnv, inherits=FALSE)
else
{
num.mod <- length(unique(modObj$ID))
assign("rf.num.mod.cache", num.mod, envir=.GlobalEnv)
}
}
# package
if (RFOPKG)
{
if(!requireNamespace("RFO", quietly = TRUE))
stop("Oracle R Distribution (ORD 3.2 or higher) is not running at ORE server")
funName <- RFO:::predict.randomForest
}
else
{
if(!requireNamespace("randomForest", quietly = TRUE))
stop("randomForest package is not installed at ORE server")
funName <- randomForest:::predict.randomForest
# modify levels for factor columns to fit predict method
# in randomForest pkg
if (cache.model)
xlevels <- mod[[1L]]$forest$xlevels
else
{
m <- ore.pull(modObj[modObj$ID == 1, c("CHUNK", "VALUE")])
m <- OREcommon:::.ore.unserialize(m$VALUE[order(m$CHUNK)])
xlevels <- m$forest$xlevels
}
for(icol in 1:length(xlevels))
{
if(is.factor(df[[icol]]))
{
if (!is.ordered(df[[icol]]))
{
if (any(! levels(df[[icol]]) %in% xlevels[[icol]]))
stop("New factor levels not present in the training data")
else
df[[icol]] <- factor(df[[icol]], levels = xlevels[[icol]])
}
}
}
}
# predict using each model
for(iMod in seq(num.mod))
{
if(cache.model)
m <- mod[[iMod]]
else
{
m <- ore.pull(modObj[modObj$ID == iMod, c("CHUNK", "VALUE")])
m <- OREcommon:::.ore.unserialize(m$VALUE[order(m$CHUNK)])
}
p <- do.call(funName, list(object = m,
newdata = df,
type = "vote",
norm.votes = FALSE))
if (iMod == 1L)
v <- p
else
v <- v + p
rm(m)
}
rm(p)
if (!(type == "response" || !norm.votes))
v[, classes] <- sweep(v[, classes, drop=FALSE],
1L, rowSums(v[, classes, drop=FALSE]), "/")
v <- as.data.frame(v)
if (type == "all" || type == "response")
{
idx <- which(!is.na(v[, 1L]))
pred <- rep.int(NA, N)
pred[idx] <- apply(v[idx, ], 1, function(x) which.max(x))
pred <- classes[pred]
if (type == "response")
v <- data.frame(prediction = pred)
else
{
v <- data.frame(v, prediction = pred)
colnames(v) <- c(classes, "prediction")
}
}
cbind(v, df[, sup.cols, drop=FALSE])
}');
-- singular value decomposition -----------------------------------------------
--
insert into rq$script (name, script) values ('RQ$SVD_MAPPER',
'function(data)
{
ans <- OREserver:::.svd.mapper(data)
if (exists(".ore.combined.output", envir=.GlobalEnv, inherits=FALSE))
{
old <- get(".ore.combined.output", envir=.GlobalEnv, inherits=FALSE)
ans <- OREserver:::.svd.reducer(old, ans)
}
assign(".ore.combined.output", ans, envir=.GlobalEnv)
structure(list(), class = "ore-using-combiner")
}');
insert into rq$script (name, script) values ('RQ$SVD_REDUCER',
'function(blockobj, nv)
{
blockobj <- ore.pull(unserialize(blockobj))
k <- length(blockobj)
ans <- blockobj[[1L]]
if (k > 1L)
{
if ((k <= 4L) || (k * object.size(ans) > 1024^3))
for (i in 2L:k)
ans <- OREserver:::.svd.reducer(ans, blockobj[[i]])
else
ans <-
Reduce(function(e1, e2)
OREserver:::.svd.reducer(e1, e2), blockobj)
}
OREserver:::.svd.finalizer(ans, nv = nv)
}');
-- predefined R/package version scripts ---------------------------------------
--
insert into rq$script (name, script) values ('RQ$R.Version',
'function()
{
v <- as.character(R.Version())
v[v == ""] <- NA_character_
data.frame(name=names(R.Version()), value=unname(v),
stringsAsFactors=FALSE)
}');
insert into rq$script (name, script) values ('RQ$getRversion',
'function()
{
data.frame(Version=as.character(getRversion()),
stringsAsFactors=FALSE)
}');
insert into rq$script (name, script) values ('RQ$installed.packages',
'function()
{
data.frame(installed.packages()[,c(1L,3L,2L),drop=FALSE],
stringsAsFactors=FALSE)
}');
insert into rq$script (name, script) values ('RQ$packageVersion',
'function(pkg)
{
data.frame(Version=as.character(packageVersion(pkg=pkg)),
stringsAsFactors=FALSE)
}');
-- predifined graphical scripts -----------------------------------------------
--
insert into rq$script (name, script) values ('RQG$plot1d',
'function(x, ...)
{
if (is.data.frame(x))
x <- x[[1L]]
if (is.character(x))
x <- as.factor(x)
plot(x, ...)
invisible(NULL)
}');
insert into rq$script (name, script) values ('RQG$plot2d',
'function(x, ...)
{
if (NCOL(x) < 2L)
stop("script RQG$plot2d requires 2 columns to produce graphic")
x <- x[1:2]
if (is.character(x[[1L]]))
x[[1L]] <- as.factor(x[[1L]])
if (is.character(x[[2L]]))
x[[2L]] <- as.factor(x[[2L]])
plot(x[1:2], ...)
invisible(NULL)
}');
insert into rq$script (name, script) values ('RQG$hist',
'function(x, ...)
{
if (is.data.frame(x))
x <- x[[1L]]
hist(x, ...)
invisible(NULL)
}');
insert into rq$script (name, script) values ('RQG$boxplot',
'function(x, ...)
{
boxplot(x, ...)
invisible(NULL)
}');
insert into rq$script (name, script) values ('RQG$smoothScatter',
'function(x, ...)
{
if (NCOL(x) < 2L)
stop("script RQG$smoothScatter requires 2 columns to produce graphic")
x <- x[1:2]
if (is.character(x[[1L]]))
x[[1L]] <- as.factor(x[[1L]])
if (is.character(x[[2L]]))
x[[2L]] <- as.factor(x[[2L]])
smoothScatter(x[1:2], ...)
invisible(NULL)
}');
insert into rq$script (name, script) values ('RQG$cdplot',
'function(x, ...)
{
if (NCOL(x) < 2L)
stop("script RQG$cdplot requires 2 columns to produce graphic")
x[[2L]] <- as.factor(x[[2L]])
cdplot(x[[1L]], x[[2L]], ...)
invisible(NULL)
}');
insert into rq$script (name, script) values ('RQG$pairs',
'function(x, ...)
{
if (NCOL(x) < 2L)
stop("script RQG$pairs requires at least 2 columns to produce graphic")
pairs(x, ...)
invisible(NULL)
}');
insert into rq$script (name, script) values ('RQG$matplot',
'function(x, ...)
{
matplot(x, ...)
invisible(NULL)
}');
commit;
-- rq_scripts -----------------------------------------------------------------
--
create view rq_scripts as
select owner, name, script
from rq$script
where owner = 'RQSYS' and REGEXP_LIKE(NAME, '^RQ.?\$');
-- rq script access -----------------------------------------------------------
--
CREATE TABLE rq$scriptAccess (
Owner VARCHAR2(128),
Name VARCHAR2(128),
Grantee VARCHAR2(128),
CONSTRAINT uk_scriptaccess UNIQUE (owner, name, grantee),
CONSTRAINT fk_scriptname FOREIGN KEY (owner, name) REFERENCES
RQ$SCRIPT (owner, name) ON DELETE CASCADE
);
-- scripts created by current user
create view USER_RQ_SCRIPTS AS
select name, script
from sys.rq$script
where owner=SYS_CONTEXT('USERENV', 'SESSION_USER');
-- private scripts created by current user and those granted to current user
-- and global ones (excluding RQ?$)
create view ALL_RQ_SCRIPTS AS
select SYS_CONTEXT('USERENV', 'SESSION_USER') owner, name, script
from USER_RQ_SCRIPTS
union all
select a.owner, a.name, a.script
from sys.rq$script a,
(select distinct owner, name from rq$scriptAccess
where (grantee IS NULL and owner != SYS_CONTEXT('USERENV', 'SESSION_USER')) or
grantee = SYS_CONTEXT('USERENV', 'SESSION_USER')) b
where a.owner = b.owner and a.name = b.name
union all
select owner, name, script
from sys.rq$script
where owner = 'RQSYS' and NOT REGEXP_LIKE(NAME, '^RQ.?\$');
-- scripts granted by current user to others
create view USER_RQ_SCRIPT_PRIVS AS
select name, NVL(grantee, 'PUBLIC') grantee
from rq$scriptAccess
where owner=SYS_CONTEXT('USERENV', 'SESSION_USER');
grant select on rq_scripts to public;
GRANT SELECT, DELETE ON RQ$SCRIPT TO RQSYS;
GRANT SELECT, INSERT, DELETE ON RQ$SCRIPTACCESS TO RQSYS;
GRANT SELECT ON ALL_RQ_SCRIPTS TO PUBLIC;
GRANT SELECT ON USER_RQ_SCRIPTS TO PUBLIC;
GRANT SELECT ON USER_RQ_SCRIPT_PRIVS TO PUBLIC;
create public synonym ALL_RQ_SCRIPTS for sys.ALL_RQ_SCRIPTS;
create public synonym USER_RQ_SCRIPTS for sys.USER_RQ_SCRIPTS;
create public synonym USER_RQ_SCRIPT_PRIVS for
sys.USER_RQ_SCRIPT_PRIVS;
--***************************************************************************--
--* (*) CONFIGURATION OPTIONS *--
--***************************************************************************--
create table rq$config(
name varchar2(128),
value varchar2(4000),
constraint rq$config_pk primary key (name));
insert into rq$config (name, value)
values ('R_HOME', NULL);
insert into rq$config (name, value)
values ('R_LIBS_USER', NULL);
insert into rq$config (name, value)
values ('VERSION', '1.5.1');
insert into rq$config (name, value)
values ('MIN_VSIZE', '32M');
insert into rq$config (name, value)
values ('MAX_VSIZE', '4G');
insert into rq$config (name, value)
values ('MIN_NSIZE', '2M');
insert into rq$config (name, value)
values ('MAX_NSIZE', '20M');
commit;
-- rq_config ------------------------------------------------------------------
--
create view rq_config as
select name, value
from rq$config;
grant select on rq_config to public;
--***************************************************************************--
--* end of file rqcrt.sql *--
--***************************************************************************--
OHA YOOOO