tests/get_col_row.R

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!")

Try the panelPomp package in your browser

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

panelPomp documentation built on June 8, 2025, 11:50 a.m.