library(testthat)
library(betr)
# test_that("Command line server works remotely", {
# cls <- CommandLineServer$new(port=12345,
# pass_request = function(name, params, ip, client) return(params["foo"]))
# cls$start()
# tmp <- socketConnection(port=12345)
# cat("test foo:bar\n", file=tmp)
# Sys.sleep(0.2)
# resp <- readLines(tmp)
# expect_that(resp, matches("bar"))
# cls$halt()
# close(tmp)
# expect_that(socketConnection(port=12345), gives_warning())
# })
test_that("RookServer works", {
rs <- RookServer$new(name="jim", clients_in_url=FALSE,
pass_request = function(name, params, ip, cookies) return(params["foo"]))
rs$start()
fake_env <- new.env()
fake_env$QUERY_STRING="foo=bar"
fake_env$rook.input = "faked"
expect_that(rs$call(fake_env)$body, equals("bar"))
rs$halt()
})
test_that("Experiment stages work", {
expt <- experiment(N=2, server="CommandLineServer", record=FALSE, seats_file=NULL)
s1 <- function(...) "Stage 1"
s2 <- stage(handler=function(...) "Stage 2")
add_stage(expt, s1, s2)
add_stage(expt, s2, after=1)
expect_that(length(expt$stages), equals(3))
add_stage(expt, s1, s2, each=2)
add_stage(expt, s1, s2, times=2)
for (i in c(4:5,8)) expect_that(expt$stages[[1]], is_equivalent_to(expt$stages[[i]]))
for (i in c(6:7,9)) expect_that(s2, is_equivalent_to(expt$stages[[i]]))
})
test_that("Experiment starting, status, pause, restart & halt work", {
expt <- experiment(N=2, server="CommandLineServer", record=FALSE, seats_file=NULL)
add_stage(expt, period(), text_stage(page="foo"))
expect_that(expt$N, equals(2))
expect_that(expt$status <- "B0rked", throws_error())
expect_that(show(expt), prints_text("Stopped"))
ready(expt)
expect_that(show(expt), prints_text("Waiting"))
expect_that(expt$handle_request(client="A", params=list()),
equals(expt$waiting_page("Waiting to start")))
expect_that(nrow(expt$subjects), equals(1))
expect_that(expt$handle_request(client="A", params=list()),
equals(expt$waiting_page("Waiting to start")))
expect_that(nrow(expt$subjects), equals(1))
expect_that(start(expt), gives_warning())
expect_that(show(expt), prints_text("Waiting"))
expect_that(expt$handle_request(client="B", params=list()),
equals(expt$waiting_page("Waiting to start")))
expect_that(nrow(expt$subjects), equals(2))
expect_that(show(expt), prints_text("Waiting"))
start(expt)
expect_that(info(expt), prints_text("Started"))
expect_that(show(expt), prints_text("Started"))
expect_that(expt$handle_request(client="C", params=list()),
equals(expt$special_page("Too many participants")))
expect_that(expt$handle_request(client="B", params=list()),
equals("foo"))
pause(expt)
expect_that(info(expt), prints_text("Paused"))
expect_that(expt$handle_request(client="B", params=list()),
equals(expt$waiting_page("Experiment paused")))
restart(expt)
expect_that(info(expt), prints_text("Started"))
expect_that(expt$handle_request(client="A", params=list()),
equals("foo"))
expect_that(expt$handle_request(client="B", params=list()),
matches("finished"))
expect_that(halt(expt), gives_warning())
expect_that(expt$handle_request(client="A", params=list()),
matches("finished"))
halt(expt)
expect_that(show(expt), prints_text("Stopped"))
expect_that(expt$handle_request(client="A", params=list()),
throws_error())
})
test_that("Command line server & client work", {
expt <- experiment(N=1, server=CommandLineServer, record=FALSE, seats_file=NULL)
s1 <- stage(handler=function(...) "Got to stage s1")
add_stage(expt, s1)
ready(expt)
expt$handle_request("jim", list())
start(expt)
expt$handle_request("jim", list())
# TODO add clclient, or is this tested in servers?
})
test_that("Rook server works with experiment", {
expt <- experiment(N=1, server="RookServer", autostart=TRUE, record=FALSE,
seats_file=NULL)
s1 <- stage(handler=function(...) "Got to stage s1")
add_stage(expt, s1)
ready(expt)
expect_that(show(expt), prints_text("Waiting"))
expect_that(expt$handle_request("jim", list()), equals("Got to stage s1"))
expt <- experiment(N=1, server="RookServer", autostart=FALSE, record=FALSE,
seats_file=NULL)
add_stage(expt, s1)
ready(expt)
expect_that(expt$handle_request("jim", list()),
equals(expt$waiting_page("Waiting to start")))
start(expt)
expect_that(expt$handle_request("jim", list()), equals("Got to stage s1"))
expt$handle_request("jim", list())
})
test_that("TextStages work", {
s1 <- text_stage(page="Foo")
expect_that(s1$handle_request(1,1, list()), equals("Foo"))
expect_that(s1$handle_request(2,1, list()), equals("Foo"))
expect_that(s1$handle_request(2,1, list()), equals(NEXT))
})
test_that("Stage naming works", {
s1 <- text_stage(page="Foo", name="my text stage")
s2 <- period(name="my period")
s3 <- checkpoint(name="my checkpoint")
s4 <- stage(name="my stage", handler=function(...) NEXT)
s5 <- program("all", function(...) NEXT, name="my program")
s6 <- timed(stage(name="my timed stage", handler=function(...) NEXT),
timeout=10)
ex <- experiment(N=1)
add_stage(ex, s1, s2, s3, s4, s5, s6)
tmp <- capture.output(print_stages(ex))
expect_that(tmp[1], matches("my text stage"))
expect_that(tmp[2], matches("my period"))
expect_that(tmp[3], matches("my checkpoint"))
expect_that(tmp[4], matches("my stage"))
expect_that(tmp[5], matches("my program"))
expect_that(tmp[6], matches("my timed stage"))
})
test_that("brew pages work", {
t2 <- tempfile("text_stage_test", fileext=".brew")
cat("bar:<%= bar %> id:<%= id %> period:<%= period %>\n", file=t2)
bar <<- "boing"
s3 <- text_stage(page=b_brew(t2))
expect_that(s3$handle_request(1,1, list()), equals("bar:boing id:1 period:1"))
})
test_that("Checkpoints work", {
expt <- experiment(N=4, server="RookServer", autostart=FALSE,
randomize_ids=FALSE, record=FALSE, seats_file=NULL)
s1 <- text_stage("foo")
s2 <- text_stage("bar")
add_stage(expt, period(), s1, checkpoint(), s2, checkpoint(c(1,2,1,2)),
s1)
ready(expt)
rfrom <- function(cl) expt$handle_request(cl, list())
clients <- paste0("client-", 1:4)
sapply(clients, rfrom)
start(expt)
sapply(clients, rfrom)
expect_that(rfrom(clients[1]), matches("Waiting"))
sapply(clients[2:3], rfrom)
expect_that(rfrom(clients[4]), equals("bar"))
expect_that(sapply(clients[1:3], rfrom), matches("bar"))
expect_that(sapply(clients[1:2], rfrom), matches("Waiting"))
expect_that(rfrom(clients[3]), equals("foo"))
expect_that(rfrom(clients[4]), equals("foo"))
expect_that(sapply(clients[1:2], rfrom), matches("foo"))
})
test_that("Programs work", {
first <- NA
seen <- numeric(0)
last <- NA
expt <- experiment(N=3, server="RookServer", autostart=FALSE,
randomize_ids=FALSE, record=FALSE, seats_file=NULL)
s1 <- program("first", function (id, period) first <<- id)
s2 <- program("all", function(id, period) seen <<- c(seen, id))
s3 <- program("last", function(id, period) last <<- id)
add_stage(expt, period(), s1, s2, s3)
ready(expt)
rfrom <- function(cl) expt$handle_request(cl, list())
clients <- paste0("client-", 1:3)
sapply(clients, rfrom)
start(expt)
rfrom(clients[1])
expect_that(first, equals(1))
sapply(clients[2:3], rfrom)
expect_that(last, equals(3))
expect_that(seen, equals(1:3))
})
test_that("Periods work", {
init_data <- function() {
myperiods <<- rep(NA,4)
seen <<- matrix(FALSE, nrow=4, ncol=4)
}
expt <- experiment(N=4, server="RookServer", autostart=FALSE,
randomize_ids=FALSE, on_ready=init_data, record=FALSE, seats_file=NULL)
s1 <- stage(handler=function(id, period, params) {
myperiods[id] <<- period
sn <- seen[id, period]
seen[id, period] <<- TRUE
if (sn) return(NEXT) else return("some html")
})
add_stage(expt, period(), s1, times=2)
expect_that(nperiods(expt), equals(2))
add_stage(expt, period("all"), s1)
add_stage(expt, period(c(1,1,2,2)), s1)
ready(expt)
expect_that(myperiods, equals(rep(NA, 4)))
rfrom <- function(cl) expt$handle_request(cl, list())
clients <- paste0("client", 1:4)
sapply(clients, rfrom)
start(expt)
sapply(clients, rfrom)
expect_that(myperiods, equals(rep(1, 4)))
rfrom(clients[1])
expect_that(myperiods, equals(c(2,1,1,1)))
sapply(clients[2:4], rfrom)
expect_that(myperiods, equals(rep(2,4)))
sapply(clients[1:3], rfrom)
expect_that(myperiods, equals(rep(2,4)))
rfrom(clients[4]) # client 4 completes the set
expect_that(myperiods, equals(c(2,2,2,3)))
sapply(clients[1:3], rfrom) # now 1-3 let through
expect_that(myperiods, equals(rep(3,4)))
rfrom(clients[1])
rfrom(clients[3])
expect_that(myperiods, equals(rep(3,4)))
rfrom(clients[2])
rfrom(clients[1])
expect_that(myperiods, equals(c(4,4,3,3)))
rfrom(clients[4])
expect_that(myperiods, equals(c(4,4,3,4)))
rfrom(clients[3])
expect_that(myperiods, equals(rep(4,4)))
})
test_that("Timed periods work", {
init_data <- function () {
mydf <<- experiment_data_frame(expt)
mydf$timed_out <<- FALSE
}
expt <- experiment(N=2, server="RookServer", autostart=FALSE,
on_ready=init_data, randomize_ids=FALSE, record=FALSE, seats_file=NULL)
s1 <- function(id, period, params) "s1"
s1t <- timed(s1, timeout=5)
s1tf <- timed(s1, timeout=5, on_timeout=function(id, period)
mydf$timed_out[mydf$id==id & mydf$period==period] <<- TRUE)
add_stage(expt, period(), s1t, text_stage("foo"), s1tf)
rfrom <- function(cl) expt$handle_request(cl, list())
clients <- paste0("client", 1:2)
ready(expt)
rfrom(clients[1])
rfrom(clients[2])
start(expt)
rfrom(clients[1])
expect_that(rfrom(clients[1])$body, equals("s1"))
rfrom(clients[2])
Sys.sleep(6)
expect_that(rfrom(clients[2]), equals("foo"))
next_stage(expt, 1)
rfrom(clients[1]) # foo
rfrom(clients[1])
rfrom(clients[1])
expect_that(mydf$timed_out[mydf$id==1 & mydf$period==1], is_false())
rfrom(clients[2])
Sys.sleep(6)
rfrom(clients[2])
expect_that(mydf$timed_out[mydf$id==2 & mydf$period==1], is_true())
})
test_that("Experiment replay works", {
td <- tempdir()
od <- setwd(td)
init_data <- function () {foo <<- 0; bar <<- 0}
expt <- experiment(N=1, autostart=TRUE, on_ready=init_data, seats_file=NULL)
s1 <- stage(handler=function(id, period, params) {foo <<- foo + 1;
bar <<- sample(1:10000000, 1)})
add_stage(expt, s1)
ready(expt)
t1 <- Sys.time() # time of expt start + a bit
snm <- expt$session_name
t2 <- as.numeric(Sys.time() - t1) # time first request at least this
expt$handle_request("jim", list(mypar="a"))
expect_that(foo, equals(1))
t3 <- as.numeric(Sys.time()-t1) # min time request 2
expt$handle_request("jim", list(mypar="b"))
expect_that(foo, equals(2))
t4 <- as.numeric(Sys.time()-t1) # min time req 3
oldbar <- bar
expt$handle_request("jim", list(mypar="c"))
expect_that(foo, equals(3))
Sys.sleep(1)
replay(expt, maxtime=t4)
expect_that(foo, equals(2))
expect_that(bar, equals(oldbar), "random number generation was different")
Sys.sleep(1)
replay(expt, maxtime=t3, folder=snm)
expect_that(foo, equals(1))
Sys.sleep(1)
replay(expt, folder=snm)
expect_that(foo, equals(3))
halt(expt, force=TRUE)
unlink(list.files(pattern=paste0("^", session_name(expt), "$")), recursive=TRUE)
expt <- experiment(N=1, seats_file=NULL)
tm <<- numeric(0)
add_stage(expt, stage(function(...) tm <<- c(tm, expt$elapsed_time()) ))
ready(expt)
expt$handle_request("client1", list())
start(expt)
Sys.sleep(1)
expt$handle_request("client1", list())
halt(expt, force=TRUE)
replay(expt)
expect_that(round(tm[1],2), equals(round(tm[2],2)),
info="Replay didn't get time right")
setwd(od)
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.