tests/testthat/test-plot.R

context("Graphics functions")
      
testthat::test_that("color", {
    cur <- palette()
    old <- lava:::mypal()
    testthat::expect_equivalent(col2rgb(cur),col2rgb(old))
    testthat::expect_equivalent(col2rgb(palette()),col2rgb(lava:::mypal(set=FALSE)))

    testthat::expect_equivalent(Col("red",0.5),rgb(1,0,0,0.5))
    testthat::expect_equivalent(Col(c("red","blue"),0.5),rgb(c(1,0),c(0,0),c(0,1),0.5))
    testthat::expect_equivalent(Col(c("red","blue"),c(0.2,0.5)),rgb(c(1,0),c(0,0),c(0,1),c(0.2,0.5)))
    testthat::expect_equivalent(Col(rgb(1,0,0),0.5),rgb(1,0,0,0.5))

    plot(0,xlim=c(0,1),ylim=c(0,1),type="n",ann=FALSE,axes=FALSE)
    devc1 <- devcoords()
    par(mar=c(0,0,0,0))
    plot(0,xlim=c(0,1),ylim=c(0,1),type="n",ann=FALSE,axes=FALSE)
    devc2 <- devcoords()
    figx <- c("fig.x1","fig.x2","fig.y1","fig.y2")
    devx <- c("dev.x1","dev.x2","dev.y1","dev.y2")
    testthat::expect_equivalent(devc1[figx],devc2[devx])    
    
})

if (requireNamespace("visualTest",quietly=TRUE)) {

    gropen <- function(resolution=200,...) {
        tmpfile <- tempfile(fileext=".png")
        png(file=tmpfile,width=200,height=200)
        res <- dev.cur()
        return(structure(tmpfile,dev=res))
    }
    grcompare <- function(file1,file2,...) {
        res <- visualTest::isSimilar(file1,file2,...)
        unlink(c(file1,file2))
        return(res)
    }

    
    testthat::test_that("plotConf", {
        set.seed(1)
        x <- rnorm(50)
        y <- rnorm(50,x)
        z <- rbinom(50,1,0.5)
        d <- data.frame(y,z,x)
        l <- lm(y~x*z)
        
        d1 <- gropen()
        par(mar=c(0,0,0,0))
        plotConf(l,var1="x",var2="z",col=c("black","blue"),alpha=0.5,legend=FALSE)
        dev.off()
        
        newd <- data.frame(x=seq(min(x),max(x),length.out=100))
        l0 <- lm(y~x,subset(d,z==0))
        ci0 <- predict(l0,newdata=newd,interval="confidence")
        l1 <- lm(y~x,subset(d,z==1))
        ci1 <- predict(l1,newdata=newd,interval="confidence")

        d2 <- gropen()
        par(mar=c(0,0,0,0))
        plot(y~x,col=c("black","blue")[z+1],pch=16,ylim=c(min(ci0,ci1,y),max(ci0,ci1,y)))
        lines(newd$x,ci0[,1],col="black",lwd=2)
        lines(newd$x,ci1[,1],col="blue",lwd=2)
        confband(newd$x,lower=ci0[,2],upper=ci0[,3],polygon=TRUE,col=Col("black",0.5),border=FALSE)
        confband(newd$x,lower=ci1[,2],upper=ci1[,3],polygon=TRUE,col=Col("blue",0.5),border=FALSE)
        points(y~x,col=c("black","blue")[z+1],pch=16)
        dev.off()
        
        testthat::expect_true(grcompare(d1,d2,threshold=5))

        
        d1 <- gropen()
        par(mar=c(0,0,0,0))
        l <- lm(y~z)
        plotConf(l,var2="z",var1=NULL,jitter=0,col="black",alpha=0.5,xlim=c(.5,2.5),ylim=range(y))
        dev.off()

        d2 <- gropen()
        par(mar=c(0,0,0,0))
        plot(y~I(z+1),ylim=range(y),xlim=c(0.5,2.5),pch=16,col=Col("black",0.5)) 
        l0 <- lm(y~-1+factor(z))
        confband(1:2,lower=confint(l0)[,1],upper=confint(l0)[,2],lwd=3,
                 center=coef(l0))
        dev.off()

        testthat::expect_true(grcompare(d1,d2,threshold=10))
                
  })


    testthat::test_that("forestplot", {
        set.seed(1)
        K <- 20
        est <- rnorm(K); est[c(3:4,10:12)] <- NA        
        se <- runif(K,0.2,0.4)        
        x <- cbind(est,est-2*se,est+2*se,runif(K,0.5,2))        
        rownames(x) <- unlist(lapply(letters[seq(K)],function(x) paste(rep(x,4),collapse="")))
        rownames(x)[which(is.na(est))] <- ""
        signif <- sign(x[,2])==sign(x[,3])        
        forestplot(x)
        ## TODO
    })

    test_that("plot.sim", {
        onerun2 <- function(a,b,...) {
            return(cbind(a=a,b=b,c=a-1,d=a+1))
        }
        R <- data.frame(a=1:2,b=3:4)
        val2 <- sim(onerun2,R=R,type=0)
        plot(val2)
        plot(val2,plot.type="single")
        density(val2)
        ## TODO
    })

    test_that("spaghetti", {
        K <- 5
        y <- "y"%++%seq(K)
        m <- lvm()
        regression(m,y=y,x=~u) <- 1
        regression(m,y=y,x=~s) <- seq(K)-1
        regression(m,y=y,x=~x) <- "b"
        d <- sim(m,5)
        dd <- mets::fast.reshape(d);
        dd$num <- dd$num+rnorm(nrow(dd),sd=0.5) ## Unbalance
        spaghetti(y~num,dd,id="id",lty=1,col=Col(1,.4),trend=TRUE,trend.col="darkblue")
        ## TODO
    })
    
    test_that("ksmooth", {
        ## TODO
    })

    test_that("plot.lvm", {
        ## TODO
        m <- lvm(y~1*u[0:1],u~1*x)
        latent(m) <- ~u
        plot(m)
        d <- sim(m,20,seed=1)
        e <- estimate(m,d)
        plot(e)
        plot(lava:::beautify(m))
        g <- igraph.lvm(m)
        testthat::expect_true(inherits(g,"igraph"))
    })
    
    test_that("images", {
        ## TODO
    })

    test_that("labels,edgelabels", {
        ## TODO
    })

    test_that("colorbar", {
        ## TODO
    })

    test_that("fplot", {
        ## TODO
    })

    test_that("interactive", {
        ## TODO
    })

    test_that("pdfconvert", {
        ## TODO
    })

    test_that("plot.estimate", {
        ## TODO
    })

    test_that("logo", {
        lava(seed=1)
    })

    
    
    
}

Try the lava package in your browser

Any scripts or data that you put into this service are public.

lava documentation built on Nov. 5, 2023, 1:10 a.m.