tests/testthat/process_testxml.R

In rgeos: Interface to Geometry Engine - Open Source ('GEOS')

library(testthat)
library(XML)
library(rgeos)

# Some functions have different names between GEOS and JTS

process_testxml = function(xmlfile, n, total, descSkip) {
    
    funcTranslate=list( "getboundary"       = list(func=gBoundary,res=readWKT,arg1=readWKT),
                        "getCentroid"       = list(func=gCentroid,res=readWKT,arg1=readWKT),
                        "convexhull"        = list(func=gConvexHull,res=readWKT,arg1=readWKT),
                        "getInteriorPoint"  = list(func=gPointOnSurface,res=readWKT,arg1=readWKT),

                        "isSimple"          = list(func=gIsSimple,res=as.logical,arg1=readWKT),
                        "isValid"           = list(func=gIsValid,res=as.logical,arg1=readWKT),

                        "isWithinDistance"  = list(func=gWithinDistance,res=as.logical,arg1=readWKT,arg2=readWKT,arg3=as.numeric),
                        "intersects"        = list(func=gIntersects,res=as.logical,arg1=readWKT,arg2=readWKT),
                        "contains"          = list(func=gContains,res=as.logical,arg1=readWKT,arg2=readWKT),
                        "within"            = list(func=gWithin,res=as.logical,arg1=readWKT,arg2=readWKT),


                        "intersection"      = list(func=gIntersection,res=readWKT,arg1=readWKT,arg2=readWKT),
                        "union"             = list(func=gUnion,res=readWKT,arg1=readWKT,arg2=readWKT),
                        "difference"        = list(func=gDifference,res=readWKT,arg1=readWKT,arg2=readWKT),
                        "symdifference"     = list(func=gSymdifference,res=readWKT,arg1=readWKT,arg2=readWKT),

                        "relate"            = list(func=gRelate,res=as.logical,arg1=readWKT,arg2=readWKT,arg3=as.character),

                        "covers"            = list(func=gCovers,res=as.logical,arg1=readWKT,arg2=readWKT),
                        "coveredBy"         = list(func=gCoveredBy,res=as.logical,arg1=readWKT,arg2=readWKT))
    
    
    context(paste('(',n,'/',total,')',basename(xmlfile)))
    #x = xmlRoot(xmlTreeParse(I(readLines(xmlfile)),ignoreBlanks=TRUE))
    x = xmlRoot(xmlTreeParse(readLines(xmlfile),ignoreBlanks=TRUE))
    
    nodes = xmlSApply(x,xmlName)

    test_that("valid node types",{
        validNodeTypes = c("precisionModel","case","comment")
        expect_that( all(nodes %in% validNodeTypes), is_true() )
    })


    #Handle precisionModel nodes - only use the first model
    pmAttrs =  xmlAttrs( x[[ which(nodes == "precisionModel")[1] ]] )

    test_that("precisionModel attribute tests", {
        expect_that( length(pmAttrs) == 1 | length(pmAttrs) == 3, is_true() )

        if (length(pmAttrs) == 1) {
            type = pmAttrs[["type"]]
        } else if (length(pmAttrs) == 3) {
            setScale(as.numeric( pmAttrs[["scale"]] ))

            expect_that( pmAttrs[["offsetx"]], equals("0.0") )
            expect_that( pmAttrs[["offsety"]], equals("0.0") )
        } 
    })

    #Handle case nodes
    for ( i in which(nodes == "case") ) {
        caseNodes = xmlSApply(x[[i]],xmlName)

        whichDesc = which(caseNodes == "desc")
        whichTests = which(caseNodes == "test")

        desc = xmlValue( x[[i]][[ whichDesc[1] ]] )
    
        if (desc %in% descSkip)
            next

        whichArgs = which(caseNodes != "desc" & caseNodes != "test")
    
        args = rep( NA,length(whichArgs) )
        # argument nodes can either contain the value or have a file attribute
        for ( j in whichArgs) {
            if (is.null( xmlAttrs(x[[i]][[j]]) )) {
                args[[ xmlName(x[[i]][[j]]) ]] = xmlValue(x[[i]][[j]])
            } else {
                file = xmlAttrs(x[[i]][[j]])[["file"]]
                args[[ xmlName(x[[i]][[j]]) ]] = paste( readLines(file), collapse="" )
            }
        }
    
        #make sure the arg names are lowercase for the sake of consistency
        names(args) = tolower(names(args))
    
        for ( j in whichTests ) {
        
            test_that(paste(desc,'- test nodes in proper format') , {
                expect_that( xmlSize( x[[i]][[j]] ), equals(1) )
                expect_that( xmlName( x[[i]][[j]][[1]] ), equals("op") )
            })
        
            if ( xmlSize( x[[i]][[j]] ) == 1 & xmlName( x[[i]][[j]][[1]] ) == "op" ) {

                opAttrs = xmlAttrs( x[[i]][[j]][[1]] )
                opReturn = xmlValue( x[[i]][[j]][[1]] )
                opNArgs = length(opAttrs)-1

                # some ops seem to have a pattern argument that is not used
                if ( 'pattern' %in% names(opAttrs) )
                    opNArgs = opNArgs-1

                opName = opAttrs[['name']]
            
               
            
                test_that(paste(desc,'-',opName), {
                
                    funcdetails = funcTranslate[[opName]]
                    expect_that( is.null(funcdetails), is_false() )
            
                    if ( !is.null(funcdetails) ) {
                        funcNArgs = length( funcdetails )-2
                        expect_that(funcNArgs==opNArgs, is_true())
                    
                        funcArgs = list()
                        for (k in 1:funcNArgs) {
                            argName = paste("arg",k,sep='')

                            argVal = tolower(opAttrs[[argName]])
                            if (argVal %in% names(args))
                                argVal = args[[ argVal ]]
                            funcArgs[k] =  funcdetails[[argName]](argVal)    
                        }
                    
                        funcReturn = do.call(funcdetails[["func"]], funcArgs)
                        expectedReturn = funcdetails[["res"]](opReturn)
                    
                        if (is.logical(funcReturn)) {
                            expect_that(funcReturn == expectedReturn, is_true())
                        } else if (is.null(funcReturn)) {
                            expect_that(is.null(funcReturn) & is.null(expectedReturn), is_true())
                        } else if (gIsEmpty(expectedReturn)) {
                            expect_that(identical(funcReturn,expectedReturn), is_true())
                        } else { # if it isn't logical or NULL it should be a geometry
                            expect_that(gEquals(funcReturn,expectedReturn),is_true())
                        }
                    }
                }) 
            }                
        } 
    }
}