#' @export
setClass(
"FLNnet",
slots = list(formula = "formula",
scoreTable = "character",
results = "list",
table = "FLTable"
) )
neuralnet <- function (formula,data=list(),...) {
UseMethod("neuralnet", data)
}
#' @export
neuralnet.default <- function (formula,data=list(),...) {
if (!requireNamespace("neuralnet", quietly = TRUE)){
stop("neuralnet package needed for neuralnet. Please install it.",
call. = FALSE)
}
else return(neuralnet::neuralnet(formula=formula,data=data,...))
}
#' \code{neuralnet} performs Neural Network on FLTable objects.
#' The DB Lytix function called is FLNNetUDT. Artificial neural networks are a family
#' of statistical learning algorithms inspired by biological neural networks
#' and are used to estimate or approximate transformations that depend on a
#' large number of inputs. Thesetransformation are then used to model the output.
#' In DB Lytix, neural network is implemented as a user-defined table function which takes
#' the input in deep format, the topography of the network along with some
#' hyper-parameters to calculate the neuron connection weights using the
#' back-propagation algorithm.
#' @seealso \code{\link[neuralnet]{neuralnet}} for R reference implementation.
#' @param formula A symbolic description of model to be fitted
#' @param data An object of class FLTable.
#' @param hidden Number of neurons in the hidden layer
#' @param layers Number of layers of Neural Net model as of now at Max 2 are alloed.
#' @param Learningrate A symbolic description of model to be fitted
#' @param isSigmoid Used to select execution mode: Regression or Classification
#' @param epoch Maximum number of iterations
#' @slot results cache list of results computed
#' @slot table Input data object
#' @method plot FLNnet
#' @method predict FLNnet
#' @return \code{neuralnet} returns an object of class \code{FLNnet}
#' @examples
#' tbl <- FLTable("tblwinetrain", obs_id_colname = "OBSID")
#' rtbl <- as.R(tbl)
#' rtbl <- rtbl[, -c(1)]
#' n <- names(rtbl)
#' f <- as.formula(paste("Wine_Type ~", paste(n[!n %in% "Wine_Type"], collapse = " + ")))
#' For 1 layer.
#' flmod <- neuralnet(f, data = tbl, hidden = c(5), layers = 1)
#' rmod <- neuralnet(f, data = rtbl, hidden = c( 5))
#' For 2 layer
#' flmod <-neuralnet(f, data = tbl, hidden = c(10,5))
#' rmod <- neuralnet(f, data = rtbl, hidden = c(10, 5))
#' library(neuralnet)
#' flmod <- neuralnet(Wine_Type~.,data=tbl, hidden = c(10, 5))
#' flmod <- neuralnet(Wine_Type~ Alcohol + Ash,data=tbl)
#' rmod <- neuralnet(Wine_Type~ Alcohol + Ash,data=rtbl, hidden = c(5,5))
#'
#' R Example:
#' library(MASS)
#' rdata <- Boston
#' n <- names(rdata)
#' f <- as.formula(paste("medv ~", paste(n[!n %in% "medv"], collapse = " + ")))
#' maxs <- apply(rdata, 2, max)
#' mins <- apply(rdata, 2, min)
#' rdata <- as.data.frame(scale(rdata, center = mins, scale = maxs - mins))
#' fltbl <- as.FL(rdata)
#' rmod <- neuralnet(f,data=rdata,hidden=c(5,3),linear.output=T)
#' flmod <- neuralnet(f, data = fltbl, hidden = c(5,3))
#' R example 2:
#' set.seed(100)
#' traininginput <- as.data.frame(runif(50, min=0, max=100))
#' trainingoutput <- sqrt(traininginput)
#' rtbl <- cbind(traininginput,trainingoutput)
#' colnames(rtbl) <- c("InputCol","OutputCol")
#' fltbl <- as.FL(rtbl)
#' rmod <- neuralnet(OutputCol~InputCol,data=rtbl,hidden=c(10),linear.output=T)
#' flmod <- neuralnet(OutputCol~InputCol,data=fltbl,hidden=c(10), IsSigmoid = 0, layers = 1)
#' @export
neuralnet.FLTable <- function(formula, data, fetchID = TRUE,hidden = 5,layers = 2,learningrate = .2,epoch = 500,IsSigmoid = 1, ...)
{
vcallObject <- match.call()
deeptblname <- gen_unique_table_name("nnetdeep")
vdeeptbl <- data
if(!isDeep(data))
{
FLdeep <- prepareData(formula = formula ,
data = data,
outDeepTable = deeptblname,
makeDataSparse = 1,
performVarReduc = 0,
minStdDev = .01,
perfromNorm = 1,
maxCorrel = .8,
fetchIDs = FALSE
)
vdeeptbl <- FLdeep$deepx
}
vmap <- FLdeep$vmapping[FLdeep$vmapping != 0]
outtblname <- gen_unique_table_name("nnetout")
data <- setAlias(data,"")
functionName <- "FLNNetUdt"
vMap <- getMatrixUDTMapping(functionName)
functionName <- vMap$funcNamePlatform
cnames <- c(GroupID = 1,
ObsID = FLdeep$deepx@select@variables$obs_id_colname,
VarID = FLdeep$deepx@select@variables$var_id_colname,
Num_Val= FLdeep$deepx@select@variables$cell_val_colname )
n1 <- n2 <- 5
if(length(hidden) == 2){
n1 <- hidden[1]
n2 <- hidden[2]
}
else if(length(hidden) == 1){
n1 <- n2 <- hidden
}
varg <- c(NeuronCountOne = n1)
if(layers ==1){
n2 <- NULL
if(is.TDAster())
varg <- c(layerstructure=fquote(as.character(varg)))
else varg <- c(varg,NeuronCountTwo = list(NULL))
}
else{
if(is.TDAster())
varg <- c(layerstructure=fquote(as.character(paste0(n1,",",n2))))
else varg <- c(varg,NeuronCountTwo = n2)
}
varg <- c(varg,
LearningRate= learningrate,
MaxEpochs = epoch,
IsSigmoid = IsSigmoid)
if(is.TDAster()){
cnames <- c(cnames,varg)
t <- createTable(outtblname,
pSelect = constructUDTSQL(pViewColnames = cnames,
pFuncName = functionName,
pOutColnames = c("a.*"),
pSelect = FLdeep$deepx@select@table_name,
pLocalOrderBy=c("GroupID", "ObsID", "VarID"),
pNest = TRUE,
pFromTableFlag = TRUE),
pPrimaryKey="partition1")
}
else
t <- createTable(outtblname,
pSelect = constructUDTSQL(pViewColnames = cnames,
pFuncName = functionName,
pOutColnames = c("a.*"),
pSelect = FLdeep$deepx@select@table_name,
pLocalOrderBy=c("GroupID", "ObsID", "VarID"),
pNest = TRUE,
pFromTableFlag = TRUE,
pArg = varg))
return(new("FLNnet",
formula=formula,
scoreTable="",
table=data,
results=list(call=vcallObject,
deeptbl = vdeeptbl,
vspec = outtblname,
vneurons = list(layers = layers, l1 =n1,l2 = n2 ),
vvars = names(vmap)
)))
}
#' @export
`$.FLNnet`<-function(object,property){
#parentObject <- deparse(substitute(object))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],",",fixed=T))[1]
if(property=="weights"){
vstr <- paste0("select LayerID,Weight from ",object@results$vspec," order by LayerID, TargetNeuronID,isBias DESC ,NeuronID")
rdf <- sqlQuery(connection, vstr)
n1 <- object@results$vneuron$l1
n2 <- object@results$vneuron$l2
if(!is.null(n2))
{vin = ((nrow(rdf) - 1 - 2*n2 - n1*n2)/n1) - 1
suppressWarnings(
weights <- list(list(layer1 = matrix(rdf$Weight[rdf$LayerID ==1],
nrow = vin+1,
ncol = n1),
layer2 = matrix(rdf$Weight[rdf$LayerID ==2],
nrow = n1+1,
ncol =n2 ),
layer3 =matrix(rdf$Weight[rdf$LayerID ==3],
nrow = n2 +1,
ncol = 1) )))}
else
{
vin <- (nrow(rdf) - 1 - 2*n1)/n1
suppressWarnings(
weights <- list(list(layer1 = matrix(rdf$Weight[rdf$LayerID ==1],
nrow = vin+1,
ncol = n1),
layer2 = matrix(rdf$Weight[rdf$LayerID ==2],
nrow = n1+1,
ncol =1 ) ))) }
return(weights) }
if(property == "call"){
return(object@results$call) }
if(property == "cost"){
vstr <- paste0("select distinct(Cost) AS Cost from ",object@results$vspec,"")
rdf <- sqlQuery(connection, vstr)
return(rdf$Cost) }
if(property == "model.list"){
return(list(response = object@results$vvars[1],
variables = object@results$vvars[2:length(object@results$vvars)]))
}
if(property == "linear.output"){
return(TRUE)
}
if(property == "result.matrix"){
vstr <- paste0("select Weight from ",object@results$vspec," order by LayerID, TargetNeuronID,NeuronID")
rdf <- sqlQuery(connection, vstr)
vrow <- nrow(rdf) + 3
vreq <- c(1, .05, 500,rdf$Weight)
vreq <- matrix(vreq,nrow = vrow, ncol = 1)
rownames(vreq) <- c("error", "reached.threshold", "steps", 1:nrow(rdf))
return(vreq)
}
}
predict.FLNnet <- function(object,newdata = object@table, ...){
var <- getVariables(object@results$deeptbl)
tblname <- gen_score_table_name("neuralscore")
functionName <- "FLNNetUdtScore"
vMap <- getMatrixUDTMapping(functionName)
functionName <- vMap$funcNamePlatform
ret <- sqlStoredProc(connection,functionName,
ModelTable = object@results$vspec,
InTable = getTableNameSlot(object@results$deeptbl),
GroupIDCol = NULL,
ObsIDCol = var[[1]],
VarIDCol = var[[2]],
NumValCol = var[[3]],
ScoreTable = tblname,
outputParameter = c(OutTable = 'a')
)
vstr <- paste0("select OBS_ID as ObsID, Actual as res from ",tblname,"")
tblfunqueryobj <- new("FLTableFunctionQuery",
connectionName = getFLConnectionName(),
variables = list(
obs_id_colname = "ObsID",
cell_val_colname = "res"),
whereconditions="",
order = "ObsID",
SQLquery=vstr)
flv <- new("FLSimpleVector",
select = tblfunqueryobj,
dimColumns = c("ObsID","res"),
Dimnames = list(rownames(newdata)),
dims = as.integer(newdata@dims[1]),
type = "integer")
return(flv) }
## set at NULL:- covariate, call, response, err.fact,
## act.fact, startweights, generalized.weights, net.result, data.
## model.list for labelling of data, result.matrix
plot.FLNnet <- function(object, ...){
reqList <- structure(
list(call = object$call,
weights = object$weights,
model.list = object$model.list,
result.matrix = object$result.matrix
),
class="nn")
return(plot(reqList,...))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.