#' @include FLTable.R
#' @include FLMatrix.R
#' @include FLVector.R
#' @include utilities.R
NULL
setOldClass("family")
#' An S4 class to represent output from gam on in-database objects
#'
#' @slot offset column name used as offset
#' @slot specid unique ID from table where specifications are stored
#' @slot family information about family of fit
#' @method print FLGAM
#' @method coefficients FLGAM
#' @method residuals FLGAM
#' @method plot FLGAM
#' @method summary FLGAM
#' @method predict FLGAM
#' @export
setClass(
"FLGAM",
contains="FLRegr",
slots=list(specid = "character",
offset="character",
family="family"))
#' Generalized Additive Models
#'
#' \code{gam} Fits a generalized additive model
#' to data given by FLTable object.
#'
#' @param data an object of class FLTable, must be a wide table
#' @param formula An R formula object with smooth terms \code{s},
#' \code{te}. In these smooth terms, \code{m} and \code{k} are specified which
#' represent splineDegree and number of knots respectively.In
#' addition, NumOfPredPts is specified through \code{xt} and byVarName
#' through \code{by}.One Can club Spline terms with same set of
#' specifications by passing more than one variables/colnames in \code{s}.
#' @param family currently only stats::poisson is supported
#' @param offset column name indicating the offset if any
#' @param maxiter maximum num of iterations
#' @param ... other arguments as in mgcv::gam may be passed
#' but not currently used
#' @section Constraints:
#' Plotting is not available. The result Set may not include all
#' results and methods as in mgcv::gam.
#' @return \code{gam} returns \code{FLGAM} object
#' @seealso \code{\link[mgcv]{gam}} for corresponding R function reference
#' @examples
#' widetable <- FLTable(getTestTableName("tblGAMSimData"),"ObsID")
#' colnames(widetable) <- tolower(colnames(widetable))
#' myformula <- yval~x0val+s(x1val,m=3,k=10)+te(x1val,x2val,m=3,k=5)+s(x2val,x1val)
#' gamobject <- gam(myformula,data=widetable,offset="x2val")
#' predictedValues <- predict(gamobject,widetable)
#' gamobject$coefficients
#' gamobject$fitted.values
#' gamobject$residuals
#' gamobject$df.null
#' print(gamobject)
#' @export
setGeneric("gam",
function(formula,
family=stats::gaussian,
data,...)
standardGeneric("gam"))
setMethod("gam",
signature(formula="formula",
data="missing"),
function(formula,family=stats::gaussian(),data=data,...){
if (!requireNamespace("mgcv", quietly = TRUE)){
stop("mgcv package needed for gam. Please install it.",
call. = FALSE)
}
else return(mgcv::gam(formula=formula,
family=family,
data=data,
...))
})
setMethod("gam",
signature(formula="formula",
data="ANY"),
function(formula,family=stats::gaussian(),data=data,...){
if (!requireNamespace("mgcv", quietly = TRUE)){
stop("mgcv package needed for gam. Please install it.",
call. = FALSE)
}
else return(mgcv::gam(formula=formula,
family=family,
data=data,
...))
})
# setMethod("gam",
# signature(formula="formula",
# data="data.frame"),
# function(formula,family=stats::gaussian(),data,...)
# mgcv::gam(formula,family,data,...))
setMethod("gam",
signature(formula="formula",
data="FLTable"),
function(formula,family=stats::poisson,
data,offset=NULL,
model=TRUE,maxiter=500,...){
if (!requireNamespace("mgcv", quietly = TRUE)){
stop("mgcv package needed for gam. Please install it.",
call. = FALSE)
}
else return(gam.FLTable(formula=formula,
family=stats::poisson,
data=data,
offset=offset,
model=model,
maxiter=maxiter,
...))
})
gam.FLTable <- function(formula,family=stats::poisson,
data,offset=NULL,
maxiter=500,...)
{
require("mgcv")
data <- setAlias(data,"")
if(is.character(family) && base::toupper(family)!="POISSON")
stop("only poisson family is supported currently\n")
if(is.function(family) && !base::identical(family,stats::poisson))
stop("only poisson family is supported currently\n")
family <- stats::poisson()
vallVars <- base::all.vars(formula)
vcolnames <- colnames(data)
sapply(vallVars,function(x)
if(!(x %in% vcolnames))
stop(x," not in colnames of data\n"))
if(is.null(offset)) offset <- offsetCopy <- "NULL"
else if(!(offset%in%vcolnames)) stop(offset," not in colnames of data\n")
else{
offsetCopy <- offset
offset <- offset
}
if(!is.numeric(maxiter) || any(maxiter<1))
stop("maxiter should be numeric and >= 1\n")
else maxiter <- as.integer(base::max(maxiter))
argList <- as.list(environment())
typeList <- list(offset="character",
maxiter="integer"
)
validate_args(argList, typeList)
callObject <- match.call()
pTerms <- c()
## Needed for eval to work. Rollback to initial values if already exist
## has to be implemented.
vrand <- genRandVarName()
getprev <- function(objectvector,vrand)
{
vlist <- base::mget(objectvector,envir=.GlobalEnv,ifnotfound=vrand)
return(sapply(vlist,function(x)x))
}
vprev <- getprev(vallVars,vrand)
sapply(vallVars,function(x) base::assign(x,rnorm(10),pos=.GlobalEnv))
tryCatch(vmodelList <- base::eval(attr(stats::terms(formula),"variables")),
error=function(e) stop("formula may be incorrect. Error is:",e,"\n"))
restoreprev <- function(objectvector,vrand)
{
options(warn=-1)
for(i in names(objectvector))
{
#browser()
if(objectvector[i]!=vrand)
assign(i,objectvector[i],pos=.GlobalEnv)
else
rm(list=i,envir=.GlobalEnv)
}
options(warn=0)
}
vtemp <- restoreprev(vprev,vrand)
vspecid <- genRandVarName()
vgamParams <- data.frame(specid=vspecid,termid=1,
varname=1,splinetype=1,
splinedegree=1,numofknots=1,
byvarname=1,smoothparam=1,
smoothdegree=1,numofpredpts=1)
vtermid <- 1
for(i in 2:length(vmodelList))
{
vattributes <- vmodelList[[i]]
## te fit
if(class(vattributes)=="tensor.smooth.spec")
{
vattributes <- vattributes$margin
for(j in 1:length(vattributes))
{
vtempattr <- vattributes[[j]]
vNumOfPredPts <- checkNumOfPredPts(vtempattr$xt[1])
vsplineDegree <- checkSplineDegree(vtempattr$p.order[1])
vNumOfKnots <- checkNumOfKnots(vtempattr$bs.dim[1],vsplineDegree)
vByVarName <- checkByVarName(vtempattr$by[1],colnames(data))
if(vByVarName!="NULL")
cat("currently byVarName not supported for tensor.Setting NULL")
d <- data.frame(fquote(vspecid),vtermid,
fquote(vtempattr$term[1]),fquote("bs"),
vsplineDegree,vNumOfKnots,
"NULL",0,
0,vNumOfPredPts)
colnames(d) <- colnames(vgamParams)
vgamParams <- base::rbind(vgamParams,d)
}
vtermid <- vtermid + 1
}
## s fit
else if(class(vattributes)=="tp.smooth.spec")
{
for(j in 1:length(vattributes$term))
{
vtempattr <- vattributes
vNumOfPredPts <- checkNumOfPredPts(vtempattr$xt[1])
vsplineDegree <- checkSplineDegree(vtempattr$p.order[1])
vNumOfKnots <- checkNumOfKnots(vtempattr$bs.dim[1],vsplineDegree)
vByVarName <- checkByVarName(vtempattr$by[1],colnames(data))
if(vByVarName!="NULL") vByVarName <- fquote(vByVarName)
d <- data.frame(fquote(vspecid),vtermid,
fquote(vtempattr$term[j]),fquote("bs"),
vsplineDegree,vNumOfKnots,
vByVarName,0,
0,vNumOfPredPts)
colnames(d) <- colnames(vgamParams)
vgamParams <- base::rbind(vgamParams,d)
vtermid <- vtermid + 1
}
}
##no-fit
else if(as.character(attr(terms(formula),"variables")[i+1]) %in% vcolnames)
{
d <- data.frame(fquote(vspecid),vtermid,
fquote(as.character(attr(terms(formula),"variables")[i+1])),fquote("na"),
"NULL","NULL",
"NULL","NULL",
"NULL",20)
vtermid <- vtermid + 1
colnames(d) <- colnames(vgamParams)
vgamParams <- base::rbind(vgamParams,d)
pTerms <- c(pTerms,as.character(attr(terms(formula),"variables")[i+1]))
}
else stop("Use mgcv::s and mgcv::te for spline specification in formula\n")
}
vgamParams <- vgamParams[-1,]
##pTerms as in R output
if(length(pTerms)==0) pTerms<-1
vformula <- paste0(vallVars[1],"~",
paste0(pTerms,collapse="+"))
pTerms <- terms(formula(vformula))
## Storing FLGAMParams
#return(vgamParams)
# vsqlstr <- base::apply(vgamParams,1,function(x){
# paste0(" INSERT INTO ",getOption("ResultDatabaseFL"),".fzzlGAMParams VALUES(",
# paste0(x,collapse=","),");")})
# vsqlstr <- paste0(vsqlstr,collapse="\n")
# sqlSendUpdate(getFLConnection(),vsqlstr)
insertIntotbl(pTableName="fzzlGAMParams",
pValues=vgamParams)
vresult <- sqlStoredProc(getFLConnection(),
"FLGAM",
outputParameter=c(AnalysisID="a"),
TableName=getTableNameSlot(data),
ObsID=getVariables(data)[["obs_id_colname"]],
DepVar=vallVars[1],
OffsetVar=offset,
ParamsSpecID=vspecid,
DistType="POISSON",
MaxIterations=maxiter,
Note=genNote("gam")
)
# vsqlstr <- paste0(" CALL FLGAM(",fquote(getTableNameSlot(data)),",",
# fquote(getVariables(data)[["obs_id_colname"]]),",",
# fquote(vallVars[1]),",",
# offset,",",
# fquote(vspecid),",'POISSON',",
# maxiter,",",
# fquote(genNote("gam")),",AnalysisID);")
# vresult <- sqlQuery(getFLConnection(),vsqlstr,
# AnalysisIDQuery=genAnalysisIDQuery("fzzlGAMInfo",genNote("gam")))
vresult <- checkSqlQueryOutput(vresult)
vanalysisId <- as.character(vresult[1,1])
return(new("FLGAM",
formula=formula,
AnalysisID=vanalysisId,
table=data,
results=list(call=callObject,
pTerms=pTerms),
specid=vspecid,
scoreTable="",
family=family,
offset=offsetCopy
))
}
#' @export
`$.FLGAM`<-function(object,property)
{
#parentObject <- deparse(substitute(object))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],",",fixed=T))[1]
if(property=="coefficients")
{
coefficientsvector <- coefficients.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(coefficientsvector)
}
else if(property=="fitted.values" || property=="linear.predictors")
{
fitvector <- fitted.values.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(fitvector)
}
else if(property=="residuals")
{
residualsvector <- residuals.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(residualsvector)
}
else if(property=="FLCoeffStdErr")
{
coeffVector <- coefficients.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(object@results[["FLCoeffStdErr"]])
}
else if(property=="FLCoeffChiSq")
{
coeffVector <- coefficients.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(object@results[["FLCoeffChiSq"]])
}
else if(property=="FLCoeffPValue")
{
coeffVector <- coefficients.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(object@results[["FLCoeffPValue"]])
}
else if(property=="call")
{
return(object@results[["call"]])
}
else if(property=="converged")
{
return(TRUE)
}
else if(property=="deviance")
{
deviancevector <- deviance.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(deviancevector)
}
else if(property=="df.residual")
{
##Reference from FLLinRegr. Not Correct Anyways.
## Actual df.residual is less than this.
df.residualsvector <- nrow(object@table)-length(object$coefficients)
assign(parentObject,object,envir=parent.frame())
return(df.residualsvector)
}
else if(property=="sig2")
{
sig2vector <- sig2.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(sig2vector)
}
else if(property=="pterms")
{
return(object@results[["pTerms"]])
}
else if(property=="assign")
{
pTerms <- object@results[["pTerms"]]
return(c(0,rep(1,length(attr(pTerms,"variables"))-2)))
}
else if(property=="nsdf")
{
return(length(object$assign))
}
else if(property=="data")
{
if(!is.null(object@results[["data"]]))
return(object@results[["data"]])
else
{
# if(interactive())
# {
# vinput <- readline("Fetching entire table. Continue? y/n ")
# if(!checkYorN(vinput)) return(NULL)
# }
object@results <- c(object@results,list(data=as.data.frame(object@table)))
assign(parentObject,object,envir=parent.frame())
return(object@results[["data"]])
}
}
else if(property=="df.null")
{
return(nrow(object@table)-1)
}
else if(property=="edf")
{
edfvector <- length(object$coefficients)-1
assign(parentObject,object,envir=parent.frame())
return(edfvector)
}
else if(property=="scale.estimated")
return(TRUE)
else if(property=="family")
return(object@family)
else if(property=="formula")
return(object@formula)
else if(property=="min.edf")
return(length(all.vars(object@formula)))
else if(property=="model")
{
modelframe <- model.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(modelframe)
}
else if(property=="terms")
{
vterms <- terms.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(vterms)
}
else if(property=="offset")
{
offsetvector <- offset.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(offsetvector)
}
else if(property=="pred.formula")
{
vallVars <- all.vars(object@formula)
vformula <- paste0("~",paste0(vallVars[2:length(vallVars)],collapse="+"))
return(formula(vformula))
}
else if(property=="prior.weights" || property=="weights")
{
return(rep(1,nrow(object@table)))
}
else if(property=="offset")
{
offsetvector <- offset.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(offsetvector)
}
else if(property=="y")
{
yvector <- y.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(yvector)
}
else if(property=="var.summary")
{
var.summaryList <- var.summary.FLGAM(object)
assign(parentObject,object,envir=parent.frame())
return(var.summaryList)
}
else if(property=="knots")
{
if(!is.null(object@results[["knots"]]))
return(object@results[["knots"]])
else
{
sqlstr <- paste0("SELECT * FROM fzzlGAMKnots WHERE ",
" analysisID='",object@AnalysisID,"'",
" ORDER BY 2,3,4")
knotsdataframe <- sqlQuery(getFLConnection(),sqlstr)
knotsdataframe <- checkSqlQueryOutput(knotsdataframe)
object@results <- c(object@results,list(knots=knotsdataframe))
assign(parentObject,object,envir=parent.frame())
return(object@results[["knots"]])
}
}
else stop(property," is not a valid property\n")
}
#' @export
setMethod("names", signature("FLGAM"), function(x) c("knots","FLCoeffStdErr",
"coefficients","fitted.levels",
"linear.predictors", "resdiduals",
"FLCoeffPValue", "FLCoeffChiSq",
"pred.formula", "prior.weights",
"var.summary", "y", "offset",
"converged", "deviance", "sig2","assign","df.residual", "pterms", "nsdf", "edf", "scale.estimated", "family","df.null", "model", "min.edf" ))
#' @export
coefficients.FLGAM <- function(object)
{
if(!is.null(object@results[["coefficients"]]))
return(object@results[["coefficients"]])
else
{
##Since Currently only 1000 coeffs are supported
## by FLGAM, fetch them.
coeffVector <- sqlQuery(getFLConnection(),
paste0("SELECT * FROM fzzlGAMCoeffs where AnalysisID=",fquote(object@AnalysisID),
" ORDER BY CoeffID"))
colnames(coeffVector) <- toupper(colnames(coeffVector))
stderrVector <- coeffVector[["STDERR"]]
chisqVector <- coeffVector[["CHISQ"]]
pvalVector <- coeffVector[["PVALUE"]]
coeffVector1 <- coeffVector[["COEFFVALUE"]]
names(coeffVector1) <- renameDuplicates(as.character(coeffVector[["COEFFTERM"]]))
# names(coeffVector1) <- paste0(coeffVector[["COEFFTERM"]],".",coeffVector[["COEFFID"]]+1)
object@results <- c(object@results,list(coefficients=coeffVector1,
FLCoeffStdErr=stderrVector,
FLCoeffChiSq=chisqVector,
FLCoeffPValue=pvalVector))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
assign(parentObject,object,envir=parent.frame())
return(coeffVector1)
}
}
#' @export
fitted.values.FLGAM <- function(object)
{
if(!is.null(object@results[["fitted.values"]]))
return(object@results[["fitted.values"]])
else
{
if(object@scoreTable=="")
# object@scoreTable <- paste0(getOption("ResultDatabaseFL"),".",gen_score_table_name(getTableNameSlot(object@table)))
object@scoreTable <- gen_score_table_name(getTableNameSlot(object@table))
if(length(object@deeptable@select@variables)>0)
vtbl <- object@deeptable
else vtbl <- object@table
fitted.valuesVector <- predict(object,vtbl,scoreTable=object@scoreTable)
object@results <- c(object@results,list(fitted.values=fitted.valuesVector))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
assign(parentObject,object,envir=parent.frame())
return(fitted.valuesVector)
}
}
#' @export
fitted.FLGAM <- fitted.values.FLGAM
#' @export
residuals.FLGAM <- function(object)
{
if(!is.null(object@results[["residuals"]]))
return(object@results[["residuals"]])
else
{
if(object@scoreTable==""){
# object@scoreTable <- paste0(getOption("ResultDatabaseFL"),".",
# gen_score_table_name(getTableNameSlot(object@table)))
object@scoreTable <- gen_score_table_name(getTableNameSlot(object@table))
fitted.valuesVector <- predict(object,object@table,scoreTable=object@scoreTable)
object@results <- c(object@results,list(fitted.values=fitted.valuesVector))
}
vtablename <- getTableNameSlot(object@table)
obs_id_colname <- getVariables(object@table)[["obs_id_colname"]]
y <- "fPred"
vobsid <- "ObsID"
# if(!isDeep(object@table))
# vYVector <- object@table[,all.vars(object@formula)[1]]
# else
# vYVector <- object@table[,"-1"]
# residualsvector <- vYVector - object@results[["fitted.values"]]
sqlstr <- paste0("SELECT '%insertIDhere%' AS vectorIdColumn,",
"a.",vobsid," AS vectorIndexColumn,",
"b.",all.vars(object@formula)[1]," - ",
"a.",y," AS vectorValueColumn",
" FROM ",object@scoreTable," a,",vtablename," b ",
" WHERE b.",obs_id_colname," = a.",vobsid)
tblfunqueryobj <- new("FLTableFunctionQuery",
connectionName = getFLConnectionName(),
variables = list(
obs_id_colname = "vectorIndexColumn",
cell_val_colname = "vectorValueColumn"),
whereconditions="",
order = "",
SQLquery=sqlstr)
residualsvector <- newFLVector(
select = tblfunqueryobj,
Dimnames = list(rownames(object@table),
"vectorValueColumn"),
isDeep = FALSE)
object@results <- c(object@results,list(residuals=residualsvector))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
assign(parentObject,object,envir=parent.frame())
return(residualsvector)
}
}
deviance.FLGAM <- function(object)
{
if(!is.null(object@results[["deviance"]]))
return(object@results[["deviance"]])
else
{
if(object@scoreTable==""){
# object@scoreTable <- paste0(getOption("ResultDatabaseFL"),".",gen_score_table_name(getTableNameSlot(object@table)))
object@scoreTable <- gen_score_table_name(getTableNameSlot(object@table))
fitted.valuesVector <- predict.FLGAM(object,object@table,scoreTable=object@scoreTable)
object@results <- c(object@results,list(fitted.values=fitted.valuesVector))
}
vtablename <- getTableNameSlot(object@table)
obs_id_colname <- getVariables(object@table)[["obs_id_colname"]]
y <- paste0(vtablename,".",all.vars(object@formula)[1])
pred <- paste0(object@scoreTable,".fPred")
sqlstr <- paste0("WITH z(yval,pred,vlog) AS ",
"(SELECT ",y," AS yval,",pred," AS pred,",
y,"/",pred," AS vlog ",
" FROM ",object@scoreTable,",",vtablename,
" WHERE ",vtablename,".",obs_id_colname," = ",
object@scoreTable,".ObsID)",
" SELECT SUM(a.vLL*a.vLL) FROM ",
"(SELECT CASE WHEN z.vlog> 0 ",
" THEN (z.yval * LOG(vlog))-(z.yval-z.pred) ELSE z.pred END AS vLL from z) as a")
deviancevector <- sqlQuery(getFLConnection(),sqlstr)
deviancevector <- checkSqlQueryOutput(deviancevector)[[1]]
object@results <- c(object@results,list(deviance=deviancevector))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
assign(parentObject,object,envir=parent.frame())
return(deviancevector)
}
}
sig2.FLGAM <- function(object)
{
if(!is.null(object@results[["sig2"]]))
return(object@results[["sig2"]])
else
{
if(object@scoreTable==""){
# object@scoreTable <- paste0(getOption("ResultDatabaseFL"),".",gen_score_table_name(getTableNameSlot(object@table)))
object@scoreTable <- gen_score_table_name(getTableNameSlot(object@table))
fitted.valuesVector <- predict.FLGAM(object,object@table,scoreTable=object@scoreTable)
object@results <- c(object@results,list(fitted.values=fitted.valuesVector))
}
vtablename <- getTableNameSlot(object@table)
obs_id_colname <- getVariables(object@table)[["obs_id_colname"]]
df.residualsvector <- object$df.residual
sqlstr <- paste0("SELECT SUM(a.vresiduals*a.vresiduals)/",df.residualsvector,
" FROM(SELECT ",
vtablename,".",all.vars(object@formula)[1]," - ",
object@scoreTable,".fPred AS vresiduals",
" FROM ",object@scoreTable,",",vtablename,
" WHERE ",vtablename,".",obs_id_colname," = ",
object@scoreTable,".ObsID) AS a")
sig2vector <- sqlQuery(getFLConnection(),sqlstr)[[1]]
object@results <- c(object@results,list(sig2=sig2vector))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
assign(parentObject,object,envir=parent.frame())
return(sig2vector)
}
}
#' @export
model.FLGAM <- function(object)
{
if(!is.null(object@results[["model"]]))
return(object@results[["model"]])
else
{
vallVars <- all.vars(object@formula)
vcolnames <- toupper(vallVars)
if(!is.null(object@results[["data"]]))
{
modelframe <- object@results[["data"]]
colnames(modelframe) <- toupper(colnames(modelframe))
modelframe <- modelframe[,vcolnames]
}
else
{
# vinput <- ""
# if(interactive())
# {
# vinput <- readline("Fetch top 10 rows only(preferred) y/n ")
# vtablename <- paste0(object@table@select@database,".",getTableNameSlot(object@table))
# if(checkYorN(vinput)) vinput <- paste0(" TOP 10 ")
# }
obs_id_colname <- getVariables(object@table)[["obs_id_colname"]]
vsqlstr <- paste0("SELECT ",paste0(vcolnames,collapse=","),
" FROM ",vtablename,
" ORDER BY ",obs_id_colname)
modelframe <- sqlQuery(getFLConnection(),vsqlstr)
modelframe <- checkSqlQueryOutput(modelframe)
}
colnames(modelframe) <- vallVars
object@results <- c(object@results,list(model=modelframe))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
assign(parentObject,object,envir=parent.frame())
return(modelframe)
}
}
#' @export
terms.FLGAM <- function(object)
{
if(!is.null(object@results[["terms"]]))
return(object@results[["terms"]])
else
{
vallVars <- all.vars(object@formula)
vformula <- paste0(vallVars[1],"~",1,"+",
paste0(vallVars[2:length(vallVars)],collapse="+"))
pTerms <- terms(formula(vformula))
object@results <- c(object@results,list(terms=pTerms))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
assign(parentObject,object,envir=parent.frame())
return(pTerms)
}
}
offset.FLGAM <- function(object)
{
if(!is.null(object@results[["offset"]]))
return(object@results[["offset"]])
else
{
if(object@offset=="NULL")
offsetvector <- rep(0,nrow(object@table))
else
{
vtablename <- getTableNameSlot(object@table)
obs_id_colname <- getVariables(object@table)[["obs_id_colname"]]
sqlstr <- paste0("SELECT '%insertIDhere%' AS vectorIdColumn,",
obs_id_colname," AS vectorIndexColumn,",
object@offset," AS vectorValueColumn",
" FROM ",vtablename)
tblfunqueryobj <- new("FLTableFunctionQuery",
connectionName = getFLConnectionName(),
variables = list(
obs_id_colname = "vectorIndexColumn",
cell_val_colname = "vectorValueColumn"),
whereconditions="",
order = "",
SQLquery=sqlstr)
offsetvector <- newFLVector(
select = tblfunqueryobj,
Dimnames = list(1:nrow(object@table),
"vectorValueColumn"),
isDeep = FALSE)
}
object@results <- c(object@results,list(offset=offsetvector))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
assign(parentObject,object,envir=parent.frame())
return(offsetvector)
}
}
var.summary.FLGAM <- function(object)
{
if(!is.null(object@results[["var.summary"]]))
return(object@results[["var.summary"]])
else
{
vallVars <- all.vars(object@formula)
vcolnames <- toupper(vallVars[2:length(vallVars)])
if(!is.null(object@results[["data"]]))
{
modelframe <- object@results[["data"]]
colnames(modelframe) <- toupper(colnames(modelframe))
modelframe <- modelframe[,vcolnames]
var.summaryList <- as.list(as.data.frame(apply(modelframe,2,summary))[c(4,3,6),])
}
else
{
vtablename <- getTableNameSlot(object@table)
obs_id_colname <- getVariables(object@table)[["obs_id_colname"]]
vsqlstr <- paste0("SELECT FLMean(",vcolnames,") AS mean1,",
"Median(",vcolnames,") AS median1,",
"FLMax(",vcolnames,") AS max1 ",
" FROM ",vtablename,collapse=" UNION ALL ")
modelframe <- sqlQuery(getFLConnection(),vsqlstr)
modelframe <- checkSqlQueryOutput(modelframe)
modelframe <- as.data.frame(t(as.matrix(modelframe)))
colnames(modelframe) <- vcolnames
var.summaryList <- as.list(modelframe)
}
object@results <- c(object@results,list(var.summary=var.summaryList))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
assign(parentObject,object,envir=parent.frame())
return(var.summaryList)
}
}
y.FLGAM <- function(object)
{
if(!is.null(object@results[["y"]]))
return(object@results[["y"]])
else
{
vallVars <- all.vars(object@formula)
vcolnames <- toupper(vallVars[1])
if(!is.null(object@results[["data"]]))
{
modelframe <- object@results[["data"]]
colnames(modelframe) <- toupper(colnames(modelframe))
yvector <- modelframe[[vcolnames]]
}
else
{
vtablename <- getTableNameSlot(object@table)
obs_id_colname <- getVariables(object@table)[["obs_id_colname"]]
sqlstr <- paste0("SELECT '%insertIDhere%' AS vectorIdColumn,",
obs_id_colname," AS vectorIndexColumn,",
vcolnames," AS vectorValueColumn",
" FROM ",vtablename)
tblfunqueryobj <- new("FLTableFunctionQuery",
connectionName = getFLConnectionName(),
variables = list(
obs_id_colname = "vectorIndexColumn",
cell_val_colname = "vectorValueColumn"),
whereconditions="",
order = "",
SQLquery=sqlstr)
yvector <- newFLVector(
select = tblfunqueryobj,
Dimnames = list(1:nrow(object@table),
"vectorValueColumn"),
isDeep = FALSE)
}
object@results <- c(object@results,list(y=yvector))
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
assign(parentObject,object,envir=parent.frame())
return(yvector)
}
}
#' @export
predict.FLGAM <- function(object,
newdata=object@table,
scoreTable="",
...)
{
newdata <- setAlias(newdata,"")
args <- list(...)
names(args) <- tolower(names(args))
vinputCols <- list(ModelSpecID=object@specid,
InAnalysisID=object@AnalysisID)
if(all(c("termidscore","byvarvalscore",
"termidparam","varname",
"byvarvalparam","varval") %in% names(args))){
vspecid <- genRandVarName()
# vsqlstr <- paste0("INSERT INTO fzzlGAMScoreParams \n ",
# "VALUES(",fquote(vspecid),",",
# args[["termidparam"]],",",
# fquote(args[["varname"]]),",",
# fquote(args[["varname"]]),",",
# args[["termidparam"]],",",
# fquote(args[["varname"]]),
# ")",collapse=";")
# sqlSendUpdate(getOption(getFLConnection()),vsqlstr)
vdf <- data.frame(vspecid,args[["termidparam"]],
args[["varname"]],args[["varname"]],
args[["termidparam"]],args[["varname"]])
insertIntotbl(pTableName="fzzlGAMScoreParams",
pValues=vdf)
vinputCols <- c(vinputCols,
InTableName="NULL",
ObsIDCol="NULL",
ScoreSpecID=vspecid,
TermID=args[["termidscore"]],
ByVarVal=args[["byvarvalscore"]]
)
}
else if(is.FLTable(newdata)){
if(isDeep(newdata)) stop("input wide table for scoring\n")
vinputCols <- c(vinputCols,
InTableName=getTableNameSlot(newdata),
ObsIDCol=getVariables(newdata)[["obs_id_colname"]],
ScoreSpecID="NULL",
TermID="NULL",
ByVarVal="NULL"
)
}
else stop("provide FLTable as newdata or ",
paste0(c("termidscore","byvarvalscore",
"termidparam","varname",
"byvarvalparam","varval"),collapse=","),
" using ... argument \n")
if(scoreTable=="")
scoreTable <- paste0(getOption("ResultDatabaseFL"),".",gen_score_table_name(getTableNameSlot(object@table)))
else if(!grep(".",scoreTable))
scoreTable <- paste0(getOption("ResultDatabaseFL"),".",scoreTable)
vinputCols <- c(vinputCols,
scoreTable=scoreTable,
Note=genNote("Scoring gam"))
AnalysisID <- sqlStoredProc(getFLConnection(),
"FLGAMScore",
outputParameter=c(AnalysisID="a"),
pInputParams=vinputCols
)
# sqlstr <- paste0("CALL FLGAMScore(",fquote(object@specid),",",
# fquote(object@AnalysisID),",",
# fquote(getTableNameSlot(newdata)),",",
# fquote(getVariables(newdata)[["obs_id_colname"]]),",",
# "NULL,",
# "NULL,",
# "NULL,",
# fquote(scoreTable),",",
# fquote(genNote("Scoring gam")),
# ",AnalysisID);")
# AnalysisID <- sqlQuery(getFLConnection(),
# sqlstr,
# AnalysisIDQuery=genAnalysisIDQuery("fzzlGAMInfo",genNote("Scoring gam")))
AnalysisID <- checkSqlQueryOutput(AnalysisID)
sqlstr <- paste0(" SELECT '%insertIDhere%' AS vectorIdColumn,",
"ObsID AS vectorIndexColumn,",
"fpred AS vectorValueColumn",
" FROM ",scoreTable)
tblfunqueryobj <- new("FLTableFunctionQuery",
connectionName = getFLConnectionName(),
variables = list(
obs_id_colname = "vectorIndexColumn",
cell_val_colname = "vectorValueColumn"),
whereconditions="",
order = "",
SQLquery=sqlstr)
flv <- newFLVector(
select = tblfunqueryobj,
Dimnames = list(1:nrow(newdata),
"vectorValueColumn"),
isDeep = FALSE)
return(flv)
}
#' @export
print.FLGAM <- function(object)
{
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
vDummyGam <- list(family=object$family,
formula=object$formula,
edf=object$edf,
df.null=object$df.null,
df.residual=object$df.residual)
class(vDummyGam) <- c("gam","glm","lm")
assign(parentObject,object,envir=parent.frame())
mgcv::print.gam(vDummyGam)
}
#' @export
setMethod("show","FLGAM",
function(object)
{
parentObject <- unlist(strsplit(unlist(strsplit(as.character(sys.call()),"(",fixed=T))[2],")",fixed=T))[1]
print(object)
assign(parentObject,object,envir=parent.frame())
}
)
checkNumOfPredPts <- function(vNumOfPredPts)
{
if(is.null(vNumOfPredPts) || is.na(vNumOfPredPts))
vNumOfPredPts <- 20
else if(is.numeric(vNumOfPredPts) && vNumOfPredPts <= 0)
{
cat("NumOfPredPts given by xt must be >0. Setting to 20")
vNumOfPredPts <- 20
}
else if(!is.numeric(vNumOfPredPts))
{
cat("NumOfPredPts given by xt must be numeric. Setting to 20")
vNumOfPredPts <- 20
}
vNumOfPredPts
}
checkSplineDegree <- function(vsplineDegree)
{
if(is.na(vsplineDegree) || is.null(vsplineDegree)) vsplineDegree <- 3
else if(!is.numeric(vsplineDegree))
{
cat("spline degree given by m should be numeric.Setting to 3")
vsplineDegree <- 3
}
else if(vsplineDegree <= 0 || vsplineDegree > 5)
{
cat("spline degree given by m must satisfy 0<m<=5.Setting to 3")
vsplineDegree <- 3
}
vsplineDegree
}
checkNumOfKnots <- function(vNumOfKnots,vsplineDegree)
{
if(is.na(vNumOfKnots) || is.null(vNumOfKnots)) vNumOfKnots <- vsplineDegree+1
else if(!is.numeric(vNumOfKnots))
{
cat("No.Of.Knots given by k should be numeric.Setting to splinedegree(m) + 1")
vNumOfKnots <- vsplineDegree + 1
}
else if(vNumOfKnots==-1)
vNumOfKnots <- vsplineDegree + 1
else if(vNumOfKnots <= 0 || vNumOfKnots <= vsplineDegree)
{
cat("No.of.knots given by k must be > splineDegree(m).Setting to m+1")
vNumOfKnots <- vsplineDegree + 1
}
vNumOfKnots
}
checkByVarName <- function(vByVarName,vcolnames)
{
if(!is.character(vByVarName))
{
cat("byVarName given by 'by' must be a character.Setting to NULL")
vByVarName <- "NULL"
}
else if(vByVarName=="NA")
vByVarName <- "NULL"
else
{
# vByVarName <- base::strsplit(vByVarName,"\"")[[1]][2]
vByVarName <- base::strsplit(vByVarName,"\"")[[1]]
if(!(vByVarName %in% vcolnames))
{
cat("byVarName given by 'by' must be in colnames of input wide table.Setting to NULL")
vByVarName <- "NULL"
}
}
vByVarName
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.