#' @include FLMatrix.R
NULL
#' @export
setGeneric("FLexpect_equal",
function(object,expected,...)
standardGeneric("FLexpect_equal"))
setMethod("FLexpect_equal",
signature(object="FLMatrix",expected="ANY"),
function(object,expected,...){
if(!(tolower(getFLPlatform()) %in% list(...)[["platforms"]]) &&
!is.null(list(...)[["platforms"]]))
return()
if(is.RSparseMatrix(expected))
expected <- matrix(expected,dim(expected))
if(class(expected)=="dist")
return(testthat::expect_equal(as.dist(as.matrix(object)),
expected,...))
testthat::expect_equal(as.matrix(object),
expected,...)
})
setMethod("FLexpect_equal",
signature(object="FLMatrix",expected="FLMatrix"),
function(object,expected,...){
if(!(tolower(getFLPlatform()) %in% list(...)[["platforms"]]) &&
!is.null(list(...)[["platforms"]]))
return()
testthat::expect_equal(as.matrix(object),
as.matrix(expected),...)
})
setMethod("FLexpect_equal",
signature(object="ANY",expected="FLMatrix"),
function(object,expected,...){
if(!(tolower(getFLPlatform()) %in% list(...)[["platforms"]]) &&
!is.null(list(...)[["platforms"]]))
return()
if(is.RSparseMatrix(object))
object <- matrix(object,dim(object))
if(class(object)=="dist")
return(testthat::expect_equal(object,
as.dist(as.matrix(expected))
,...))
testthat::expect_equal(object,
as.matrix(expected),...)
})
setMethod("FLexpect_equal",
signature(object="FLSimpleVector",expected="ANY"),
function(object,expected,...){
if(!(tolower(getFLPlatform()) %in% list(...)[["platforms"]]) &&
!is.null(list(...)[["platforms"]]))
return()
testthat::expect_equal(as.vector(object),
expected,...)
})
setMethod("FLexpect_equal",
signature(object="FLVector",expected="ANY"),
function(object,expected,...){
if(!(tolower(getFLPlatform()) %in% list(...)[["platforms"]]) &&
!is.null(list(...)[["platforms"]]))
return()
testthat::expect_equal(as.vector(object),
expected,...)
})
setMethod("FLexpect_equal",
signature(object="FLSkalarAggregate",expected="ANY"),
function(object,expected,...){
if(!(tolower(getFLPlatform()) %in% list(...)[["platforms"]]) &&
!is.null(list(...)[["platforms"]]))
return()
testthat::expect_equal(as.vector(object),
expected,...)
})
setMethod("FLexpect_equal",
signature(object="FLVector",expected="FLVector"),
function(object,expected,...){
if(!(tolower(getFLPlatform()) %in% list(...)[["platforms"]]) &&
!is.null(list(...)[["platforms"]]))
return()
testthat::expect_equal(as.vector(object),
as.vector(expected),...)
})
setMethod("FLexpect_equal",signature(object="list",expected="list"),
function(object,expected,...)
llply(names(object),
function(i)
FLexpect_equal(object[[i]],
expected[[i]],...)))
setMethod("FLexpect_equal",
signature(object="ANY",expected="FLSimpleVector"),
function(object,expected,...){
if(is.numeric(object) || is.integer(object) || is.vector(object)){
return(FLexpect_equal(expected,object,...))
}
else FLexpect_equal(as.FLVector(object),
expected,...)
})
setMethod("FLexpect_equal",
signature(object="ANY",expected="FLVector"),
function(object,expected,...){
if(is.numeric(object) || is.integer(object) || is.vector(object)){
# object <- as.vector(object)
# return(testthat::expect_equal(object,as.R(expected),...))
return(FLexpect_equal(expected,object,...))
}
else FLexpect_equal(as.FLVector(object),
expected,...)
})
setMethod("FLexpect_equal",
signature(object="ANY",expected="FLSkalarAggregate"),
function(object,expected,...){
if(is.numeric(object) || is.integer(object) || is.vector(object)){
# object <- as.vector(object)
# return(testthat::expect_equal(object,as.R(expected),...))
return(FLexpect_equal(expected,object,...))
}
else FLexpect_equal(as.FLVector(object),
expected,...)
})
setMethod("FLexpect_equal",
signature(object="ANY",expected="ANY"),
function(object,expected,...){
if(!(tolower(getFLPlatform()) %in% list(...)[["platforms"]]) &&
!is.null(list(...)[["platforms"]]))
return()
if(is.FL(object))
object <- as.R(object)
if(is.FL(expected))
expected <- as.R(expected)
testthat::expect_equal(object,
expected,...)
})
setMethod("FLexpect_equal",signature(object="FLTable",expected="ANY"),
function(object,expected,...){
if(!(tolower(getFLPlatform()) %in% list(...)[["platforms"]]) &&
!is.null(list(...)[["platforms"]]))
return()
testthat::expect_equal(as.data.frame(object),
as.data.frame(expected),...)
})
##' Evaluates the expression e in an R and an FL environment, tests assignment for equality.
##'
##' Tests all variables in expectation and new variable names for equality in R and FL environments.
##' Created objects will be in both environments.
##' The results of both expressions will be returned together with benchmarking statistics.
##'
##' TDOD: collect more information: length of sql sent, amount of data fetched
##'
##'
##' @param e the expression that will be evaluated in both environments
##' @param Renv
##' @param FLenv
##' @param description if not supplied will default to deparse of the expression
##' @param runs if runs>1 the expressions are evaluated several times. Make sure you do not re-assign the variables in environments that are evaluated on.
##' @param expectation provide variable names to check for equality when environments did already contain these variables.
##' @param noexpectation You can exclude names from
##' @param ... arguments passed to FLexpect_equal, e.g. check.attributes = FALSE
##' @return a data frame with the description
##' @author Gregor Kappler <gregor.kappler@@fuzzylogix.com>
#' @export
eval_expect_equal <- function(e, Renv, FLenv,
description=NULL,
runs=1,
expectation=c(),
noexpectation=c(),
verbose=FALSE,
platforms=c("TD","TDAster","Hadoop"),
...){
if(runs>=1)
e <- substitute(e)
if(runs>1)
return(ldply(1:runs,
function(i) eval_expect_equal(e,
Renv, FLenv,
description=description,
runs=-1,...)))
if(is.null(description)) description <- paste(deparse(e),collapse="\n")
## check platform specific info if any in the description
## and run on those platforms only.
if(!(tolower(getFLPlatform()) %in% tolower(platforms)))
return()
oldNames <- ls(envir = Renv)
rStartT <- Sys.time()
re <- tryCatch({
eval(expr = e, envir=Renv)
NULL
}, error=function(err) {
print(err)
err
})
rEndT <- Sys.time()
flStartT <- Sys.time()
fle <- tryCatch({
eval(expr = e, envir=FLenv)
NULL
}, error=function(err) {
print(err)
err
})
flEndT <- Sys.time()
if(is.null(re))
expect_null(fle,label=fle)
##expect_equal(e,fle)
newNames <- ls(envir = Renv)
vToCheckNames <- setdiff(newNames,oldNames)
if(length(noexpectation)>0)
vToCheckNames <- setdiff(vToCheckNames,noexpectation)
if(length(expectation)>0)
vToCheckNames <- c(expectation,vToCheckNames)
for(n in unique(vToCheckNames)){
rObject <- get(n,envir = Renv)
flObject <- get(n,envir = FLenv)
if(verbose) {
cat(paste0("---------\n Testing for equality: ",n,"\n R:\n"))
str(rObject)
cat(paste0(" FL:\n"))
str(flObject)
}
FLexpect_equal(rObject, flObject,label=n,...)
}
## TODO: store statistics in database
## TODO: cbind values set in expression
return(data.frame(description = description,
r.Runtime = rEndT-rStartT,
fl.Runtime = flEndT-flStartT))
}
#' DEPRECATED: use eval_expect_equal
#' @export
expect_eval_equal <- function(initF,FLcomputationF,RcomputationF,...)
{
if(!is.null(list(...)[["platforms"]]))
if(!(tolower(getFLPlatform()) %in% tolower(list(...)[["platforms"]])))
return()
I <- initF(...)
FLexpect_equal(FLcomputationF(I$FL),
RcomputationF(I$R),
check.attributes=FALSE)
}
#' @export
expect_flequal <- function(a,b,...){
if(is.list(a))
for(i in 1:length(a))
expect_flequal(a[[i]],b[[i]],...)
FLexpect_equal(a,b,...)
}
## gk: refactor such that initF code is used for one-time creation of huge testing tables (on demand)
## gk: and that all actual testing is done by creating references to that permanent table
## type should be in c("float","int","character")
#' @export
initF.FLVector <- function(n,isRowVec=FALSE,type = "float",...)
{
if(n>1000000)
stop("maximum n allowed is 1000000 \n ")
else if(!isRowVec){
if(type=="float")
{
select <- new("FLSelectFrom",
connectionName = getFLConnectionName(),
##database = getOption("ResultDatabaseFL"),
table_name = getRemoteTableName(databaseName=getOption("TestDatabase"),
tableName="fzzlserial"),
variables = list(obs_id_colname="SERIALVAL"),
# whereconditions=paste0(getRemoteTableName(databaseName=getOption("TestDatabase"),
# tableName = "fzzlserial",
# temporaryTable=FALSE),".SERIALVAL < ",n+1),
whereconditions=paste0("SERIALVAL < ",n+1),
order = "")
flv <- newFLVector(
select=select,
Dimnames=list(1:n,"RANDVAL"),
isDeep=FALSE,
type="double")
}
# else if(is.null(getOption("FLTestVectorTable")) ||
# !getOption("FLTestVectorTable"))
else
{
# if(!checkRemoteTableExistence(tableName="ARTestIntVectorTable"))
if(type=="int"){
vtableName <- "ARTestIntVectorTable"
vtemp <- createTable(pTableName="ARTestIntVectorTable",
pSelect=paste0(" SELECT a.serialval AS vectorIndexColumn, \n ",
" CAST(FLSimUniform(a.serialval,-100,100) AS INT) AS vectorValueColumn \n ",
" FROM fzzlserial a "),
pTemporary=FALSE,
pPrimaryKey="vectorIndexColumn",
pPermanent=1)
}
else{
vtemp <- createTable(pTableName="ARTestCharVectorTable",
pSelect=paste0(" SELECT a.serialval AS vectorIndexColumn, \n ",
" b.string1 AS vectorValueColumn \n ",
" FROM fzzlserial a, \n ",
"(SELECT ROW_NUMBER()OVER(ORDER BY string1) AS obsid, \n ",
"string1 \n ",
" FROM tblstring ) AS b \n ",
" WHERE FLMOD(a.serialval,5) + 1 = b.obsid "),
pTemporary=FALSE,
pPrimaryKey="vectorIndexColumn",
pPermanent=1)
vtableName <- "ARTestCharVectorTable"
}
# options(FLTestVectorTable=TRUE)
select <- new("FLSelectFrom",
connectionName = getFLConnectionName(),
table_name = vtableName,
variables = list(obs_id_colname="vectorIndexColumn"),
whereconditions=paste0(vtableName,".vectorIndexColumn < ",n+1),
order = "")
flv <- newFLVector(
select=select,
Dimnames=list(1:n,"vectorValueColumn"),
isDeep=FALSE,
type="integer")
}
}
else{
if(type == "character"){
widetable<-FLTable(getRemoteTableName(tableName = "tblAutoMpg",temporaryTable = FALSE),"ObsID")
flv <- widetable[1,rep("CarName",n)]
}
else{
vmaxId <- getMaxVectorId()
sqlSendUpdate(getFLConnection(),
c(paste0("INSERT INTO ",getOption("ResultVectorTableFL")," \n ",
" SELECT ",vmaxId," AS vectorIdColumn, \n ",
" a.serialval AS vectorIndexColumn, \n ",
#CAST(RANDOM(0,100) AS FLOAT)AS VECTOR_VALUE
"a.RANDVAL +1 AS vectorValueColumn \n ",
" FROM ", getRemoteTableName(tableName = "fzzlserial", temporaryTable=FALSE)," a \n ",
" WHERE a.serialval <= ",n)))
table <- FLTable(getOption("ResultVectorTableFL"),
"vectorIndexColumn",
whereconditions=paste0(getOption("ResultVectorTableFL"),
".vectorIdColumn = ",vmaxId)
)
flv <- table[,"vectorValueColumn"]
}
}
Rvector <- as.vector(flv)
if(type=="int")
Rvector <- as.integer(Rvector)
return(list(FL=flv,R=Rvector))
}
## Increase the value of n to increase the dimensions of FLMatrix returned.
## Returns n*n or n*(n-1) based on isSquare.
## type should be in c("float","int","character")
#' @export
initF.FLMatrix <- function(n,isSquare=FALSE,type="float",...)
{
if(any(n>1000))
stop("maximum rows,cols allowed is 1000 \n ")
## here manually set option as true if tables exist.
vFromTable <- getRemoteTableName(tableName="fzzlserial")
valExpression <- " FLSimUniform(a.serialval*100+b.serialval,0,1)*1000 "
if(is.Hadoop())
valExpression <- paste0(" CASE WHEN ",getMODSQL(pColumn1="(a.serialval+b.serialval)",pColumn2=2),
" = 0 THEN (a.randval+b.randval+b.randval)*100 ",
" ELSE (a.randval-b.randval-b.randval)*100 END ")
if(type=="int")
{
vtableName <- "ARTestIntMatrixTable"
valExpression <- paste0(" CAST( ",valExpression," AS INT)")
}
else if(type=="character"){
vtableName <- "ARTestCharMatrixTable"
valExpression <- paste0(" CAST( ",valExpression," AS VARCHAR)")
}
else if(type=="float"){
vtableName <- "ARTestMatrixTable"
}
else stop("type should be int,float,character")
if(!checkRemoteTableExistence(tableName=vtableName))
vtemp <- createTable(pTableName=vtableName,
pSelect=paste0(" SELECT a.serialval AS rowIdColumn, \n ",
" b.serialval AS colIdColumn, \n ",
valExpression, " AS valueColumn \n ",
" FROM ",vFromTable," a,",
vFromTable," b \n ",
" WHERE a.serialval < 1001 \n ",
" AND b.serialval < 1001 "),
pTemporary=FALSE,
pDrop=TRUE,
pPrimaryKey=c("rowIdColumn"),
pPermanent=1
)
else
vtemp <- vtableName
select <- new("FLSelectFrom",
connectionName = getFLConnectionName(),
table_name = c(mtrx=vtableName),
variables=list(MATRIX_ID="'%insertIDhere%'",
rowIdColumn=paste0("mtrx.rowIdColumn"),
colIdColumn=paste0("mtrx.colIdColumn"),
valueColumn=paste0("mtrx.valueColumn")),
whereconditions=c(paste0("mtrx.rowIdColumn < ",n+1),
paste0("mtrx.colIdColumn < ",ifelse(isSquare,n+1,n))),
order = "")
flm <- newFLMatrix(
select = select,
dims = as.integer(c(n,ifelse(isSquare,n,n-1))),
Dimnames = list(NULL,NULL))
return(list(FL=flm,R=as.matrix(flm)))
}
#' @export
initF.FLTable <- function(rows,cols,...)
{
WideTable <- FLTable(c(flt=getRemoteTableName(databaseName=getOption("TestDatabase"),
tableName = "fzzlserial",
temporaryTable=FALSE)),
"SERIALVAL",
whereconditions=paste0("SERIALVAL < ",rows+1))
return(WideTable[1:rows,base::sample(c("RANDVAL","SERIALVAL"),cols,replace=TRUE)])
}
initF.numeric <- initF.FLVector
initF.data.frame <- initF.FLTable
initF.matrix <- initF.FLMatrix
##' initF.default helps to return a list of list.
##' Can be used for comparing results of R and FL functions which require two objects.
initFgeneric<- function(specs=list(numberattribute =5,featureattribute = TRUE,...),
class = "FLMatrix"){
#browser()
if(class%in%c("FLVector","FLMatrix","FLTable")){
obj<-do.call(paste0("initF.",class),specs)
}
else{
obj<-do.call(paste0("initF.",class),specs)
if(class == "numeric")
obj<-do.call("as.vector",list(obj))
else
obj<-do.call(paste0("as.",class),list(obj))
}
return(obj)
}
## gk: think of a better name FL_test_operators
## gk: document
FL_test_generic<-function(specs=list(list(n=5,isSquare = TRUE,...),
list(n =5,isRowVec = FALSE,...)),
classes = c("FLMatrix","FLVector"),
operator = "+"){
FLenv<-new.env()
##browser()
lapply(1:length(classes),function(i){
obj<-initFgeneric(specs[[i]],classes[i])
x=i
assign(paste0("a",x),obj,envir = FLenv)
})
Renv<-as.R(FLenv)
obj1<-do.call(operator,lapply(ls(FLenv),function(x)do.call("$",list(FLenv,paste0(x)))))
obj2<-do.call(operator,lapply(ls(Renv),function(x)do.call("$",list(Renv,paste0(x)))))
FLexpect_equal(obj1,obj2,check.attributes =FALSE)
}
##' initF.default helps to return a list of list.
##' Can be used for comparing results of R and FL functions which require two objects.
initFdefault<- function(specs=list(c(n=5,isSquare = TRUE),c(n =5,isRowVec = FALSE)),
classes = c("FLMatrix","FLVector")){
#browser()
l<-lapply(1:length(classes),function(x){
#browser()
I <- do.call(paste0("initF.",classes[x]),list(specs[[x]]))
return(I)
})
FL <- lapply(1:length(l),function(x){
#browser()
if(classes[x] %in% c("FLMatrix","FLVector","FLTable"))
subscript <- "FL"
else subscript <- "R"
return(do.call("$",list(l[[x]],subscript)))
})
R <- lapply(1:length(l),function(x)l[[x]]$"R")
return(list(FL=FL,R=R))
}
##' tests if a R matrix is correctly stored and
##' represented when casting the R matrix into FLMatrix
##' and correctly recieved back, when cast to a vector.
##' checking dimnames, checking for subsetting.
##' For an optical check, both matrices are printed.
##'
##' @param a an R Matrix
##' @author Gregor Kappler <g.kappler@@gmx.net>
##' @export
expect_equal_RMatrix_FLMatrix <- function(a){
# browser()
debugOld <- getOption("debugSQL")
options(debugSQL=FALSE)
b <- as.FLMatrix(a)
a <- Matrix(a)
options(debugSQL=debugOld)
expect_equal_Matrix(a,b,
"cast Matrix equal")
test_Matrix_Subsetting(a,b,"as.FLMatrix")
}
##' converts FLMatrix to r matrix and checks if
##' recursive identical subsetting results in identical
##' matrices.
##'
##' @param b FLMatrix
##' @author Gregor Kappler <g.kappler@@gmx.net>
##' @export
test_equal_FLMatrix_RMatrix<- function(b){
# browser()
debugOld <- getOption("debugSQL")
options(debugSQL=FALSE)
a <- as.matrix(b)
options(debugSQL=debugOld)
expect_equal_Matrix(a,b,
"cast Matrix equal")
test_Matrix_Subsetting(a,b,"as.FLMatrix")
}
##' tests matrix subsetting by names and by index recursively.
##'
##' @param a
##' @param b
##' @param desc
##' @author Gregor Kappler <g.kappler@@gmx.net>
##' @export
test_Matrix_Subsetting <- function(a,b, desc=""){
if(nrow(a)<3) return()
nr <- nrow(a) -2 ##%/% 2
nc <- ncol(a) -2 ## %/% 2
rowi <- sample(1:nrow(a),nr)
coli <- sample(1:ncol(a),nc)
asel <- a[rowi,coli,drop=FALSE]
bsel <- b[rowi,coli,drop=FALSE]
expect_equal_Matrix(asel,bsel,
paste0(
"subset by index of ",
desc))
## recursively test!
test_Matrix_Subsetting(asel,bsel,
paste0(
"indexed subset of ",
desc))
if(!is.null(rownames(a)))
rowi <- sample(rownames(a),nr)
if(!is.null(colnames(a)))
coli <- sample(colnames(a),nc)
asel <- a[rowi,coli,drop=FALSE]
bsel <- b[rowi,coli,drop=FALSE]
expect_equal_Matrix(asel,bsel,
paste0(
"subset by names of ",
desc))
## recursively test!
test_Matrix_Subsetting(asel,bsel,
paste0(
"named subset of ",
desc))
}
##' @export
expect_equal_Matrix <- function(a,b,desc="",verbose=FALSE){
if(verbose==TRUE){
cat("\n-------------- ",desc,"\nR Matrix Object:\n")
print(a)
cat("\nFL Matrix Object:\n")
print(b)
}
stripNames <- function(x) {
if(is.null(x)) return(NULL)
if(is.numeric(x) & all(x==as.numeric(names(x))))
x <- NULL
else
names(x) <- NULL
if(is.list(x)) x <- llply(x,stripNames)
##if(is.null(unlist(x))) x <- NULL
x
}
test_that(desc,{
testthat::expect_equal(dimnames(a),stripNames(dimnames(b)))
testthat::expect_equal(rownames(a),stripNames(rownames(b)))
testthat::expect_equal(colnames(a),stripNames(colnames(b)))
testthat::expect_equal(as.vector(a),as.vector(b))
})
}
expect_equal_RVector_FLVector <- function(a){
# browser()
debugOld <- getOption("debugSQL")
options(debugSQL=FALSE)
b <- as.FLVector(a)
options(debugSQL=debugOld)
expect_equal_Vector(a,b,
"cast Vector equal")
test_Vector_Subsetting(a,b,"as.FLVector")
if(!is.null(names(a)))
test_Vector_Subsetting(a,b,"as.FLVector",index=FALSE)
}
#' @export
expect_equal_FLSimpleVector_RVector <- function(a){
# browser()
debugOld <- getOption("debugSQL")
options(debugSQL=FALSE)
b <- as.vector(a)
options(debugSQL=debugOld)
expect_equal_Vector(b,a,
"cast Vector equal")
test_Vector_Subsetting(b,a,"as.FLVector")
if(!is.null(names(a)))
test_Vector_Subsetting(b,a,"as.FLVector",index=FALSE)
}
##' tests vector subsetting by names and by index recursively.
##'
##' @param a
##' @param b
##' @param desc
##' @author Gregor Kappler <g.kappler@@gmx.net>
##' @export
test_Vector_Subsetting <- function(a,b, desc="",index=TRUE){
if(length(a)<3) return()
len <- length(a)-2
if(index){
leni <- sample(1:length(a),len)
## cat("index is ... ",leni,"\n")
asel <- a[leni]
bsel <- b[leni]
expect_equal_Vector(asel,bsel,
paste0(
"subset by index of ",
desc))
## recursively test!
test_Vector_Subsetting(asel,bsel,
paste0(
"indexed subset of ",
desc),index=index)
}
else{
leni <- sample(names(a),len)
## cat("index is ... ",leni,"\n")
asel <- a[leni]
bsel <- b[leni]
expect_equal_Vector(asel,bsel,
paste0(
"subset by names of ",
desc))
## recursively test!
test_Vector_Subsetting(asel,bsel,
paste0(
"named subset of ",
desc),index=index)
}
}
##' @export
expect_equal_Vector <- function(a,b,desc="",debug=FALSE){
if(debug==TRUE){
cat("\n-------------- ",desc,"\nR vector Object:\n")
print(a)
cat("\nFLVector Object:\n")
print(b)
}
# stripNames <- function(x) {
# if(is.null(x)) return(NULL)
# if(is.numeric(x) & all(x==as.numeric(names(x))))
# x <- NULL
# else
# names(x) <- NULL
# if(is.list(x)) x <- llply(x,stripNames)
# ##if(is.null(unlist(x))) x <- NULL
# x
# }
test_that(desc,{
if(!is.null(names(a)))
testthat::expect_equal(names(a),as.character(as.vector(names(b))))
testthat::expect_equal(a,as.vector(b))
})
}
initF.numeric <- initF.FLVector
initF.data.frame <- initF.FLTable
initF.matrix <- initF.FLMatrix
#' @export
dropFLTestTable <- function(){
dropTable(pTableName="ARBaseTestTempTable")
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.