tests/get_col_row.R

In panelPomp: Inference for Panel Partially Observed Markov Processes

if (file.exists("_options.R")) source("_options.R")
library(panelPomp,quietly=TRUE)

TESTS_PASS <- NULL
test <- function(expr1,expr2,all="TESTS_PASS",env=parent.frame(),...)
  panelPomp:::test(expr1,expr2,all=all,env=env,...)

## write rows in r= & columns in c=
m1x1 <- matrix(
  paste0(rep(paste0(1:c(r=1),"_"),times=c(c=1)),rep(seq(1,c(c=1)),each=c(r=1))),
  nrow=c(r=1),dimnames=list(paste0("r",1:c(r=1)),c(paste0("c",1:c(c=1)))))
m1x2 <- matrix( ## named rownames and colnames!
  paste0(rep(paste0(1:c(r=1),"_"),times=c(c=2)),rep(seq(1,c(c=2)),each=c(r=1))),
  nrow=c(r=1),dimnames=list(rnm=paste0("r",1:c(r=1)),cnm=c(paste0("c",1:c(c=2)))))
m2x5 <- matrix(
  paste0(rep(paste0(1:c(r=2),"_"),times=c(c=5)),rep(seq(1,c(c=5)),each=c(r=2))),
  nrow=c(r=2),dimnames=list(paste0("r",1:c(r=2)),c(paste0("c",1:c(c=5)))))

# tests for get_col
############################################[rows,col]###############[rows]
test(get_col(m1x1,rows=1,col=1),
     setNames(m1x1[rows=1,col=1],nm=rownames(m1x1)[rows=1]))
test(get_col(m1x2,rows=1,col=1),
     setNames(m1x2[rows=1,col=1],nm=rownames(m1x2)[rows=1]))
test(get_col(m1x2,rows=1,col=1),
     setNames(m1x2[rows=1,col=1],nm=rownames(m1x2)[rows=1]))
test(get_col(m2x5,rows=1,col=1),
     setNames(m2x5[rows=1,col=1],nm=rownames(m2x5)[rows=1]))
test(get_col(m2x5,,col=1),setNames(m2x5[,col=1],nm=rownames(m2x5)[]))
# tests for get_row
############################################[rows,col]###############[rows]
test(get_row(m1x1,cols=1,row=1),
     setNames(m1x1[row=1,cols=1],nm=colnames(m1x1)[cols=1]))
test(get_row(m2x5,cols=1,row=1),
     setNames(m2x5[row=1,cols=1],nm=colnames(m2x5)[cols=1]))
test(get_row(m2x5,,row=1),setNames(m2x5[row=1,],nm=colnames(m2x5)[]))

## check whether all tests passed
all(get(eval(formals(test))$all))
if (!all(get(eval(formals(test))$all))) stop("Not all tests passed!")