I am working on a poker deck prability simulation. I would like to get the probability that player 1 is dealt a hand consisting of a single suit only.
I got the code below, however, I get the following error:
> checkDeck1()
Error in unique(deck[1:4]) : argument "deck" is missing, with no default
Code:
pokerdeck <- rep(LETTERS[1:4],13)
deck <- sample(x=pokerdeck, size=13) #Deck of player 1!
checkDeck1 <- function(deck) {
uniquedeck <- unique(deck[1:13])
## if it is only a single suit
if (length(uniquedeck)==1) {
rv <- TRUE
} else {
rv <- FALSE
}
return (rv)
}
checkDeck1()
You want to call
checkDeck1(deck)
In the code of your function checkDeck1, the scope of the variable deck is local - the fact that you name this variable like a global variable locally overwrites it.
Related
I need to test package loading operations (for my multiversion package) and know that unloading namespaces and stuff is dangerous work. So I want to run every test in a fresh R session. Running my tests in parallel does not meet this demand since it will reuse slaves, and these get dirty.
So I thought callr::r would help me out. Unfortunately I am again stuck with the minimally documented reporters it seems.
The following is a minimal example. Placed in file test-mytest.R.
test_that('test 1', {
expect_equal(2+2, 5)
})
reporter_in <- testthat::get_reporter()
# -- 1 --
reporter_out <- callr::r(
function(reporter) {
reporter <- testthat::with_reporter(reporter, {
testthat::test_that("test inside", {
testthat::expect_equal('this', 'wont match')
})
})
},
args = list(reporter = reporter_in),
show = TRUE
)
# -- 2 --
testthat::set_reporter(reporter_out)
# -- 3 --
test_that('test 2', {
expect_equal(2+2, 8)
})
I called this test file using:
# to be able to check the outcome, work with a specific reporter
summary <- testthat::SummaryReporter$new()
testthat::test_file('./tests/testthat/test-mytest.R', reporter = summary)
Which seems to do what I want, but when looking at the results...
> summary$end_reporter()
== Failed ===============================================================================================
-- 1. Failure (test-load_b_pick_last_true.R:5:5): test 1 ------------------------------------------------
2 + 2 (`actual`) not equal to 5 (`expected`).
`actual`: 4
`expected`: 5
== DONE =================================================================================================
...it is only the first test that is returned.
How it works:
An ordinary test is executed.
The reporter, currently in use, is obtained (-- 1 --)
callr::r is used to call a testthat block including a test.
Within the call, I tried using set_reporter, but with_reporter is practically identical.
The callr::r call returns the reporter (tried it with get_reporter(), but with_reporter also returns the reporter (invisibly))
Now the returned reporter seems fine, but when setting it as the actual reporter with set_reporter, it seems that it is not overwriting the actual reporter.
Note that at -- 2 --, the reporter_out contains both test outcomes.
Question
I am not really sure what I expect it to do, but in the end I want the results to be added to the original reporter ((summary or) reporter_in that is, if that is not some kind of copy).
One workaround I can think of would be to move the actual test execution outside of the callr::r call, but gather the testcases inside.
I think it is neat, as long as you can place these helper functions (see the elaborate example) in your package, you can write tests with little overhead.
It doesn't answer how to work with the 'reporter' object though...
Simple example:
test_outcome <- callr::r(
function() {
# devtools::load_all()
list(
check1 = mypackage::sum(5,5), # some imaginary exported functions sum and name.
check2 = mypackage::name()
)
}
)
test_that('My test case', {
expect_equal(test_outcome$check1, 10)
expect_equal(test_outcome$check2, 'Siete')
})
Elaborate example
Note that from .add_test to .exp_true are only function definitions which can better be included in your package so they will be available when being loaded with devtools::load_all(). load_all also loads not-exported functions by default.
test_outcome <- callr::r(
function() {
# devtools::load_all()
# Defining helper functions
tst <- list(desc = 'My first test', tests = list())
.add_test <- function(type, A, B) {
# To show at least something about what is actually tested when returning the result, we can add the actual `.exp_...` call to the test.
call <- as.character(sys.call(-1))
tst$tests[[length(tst$tests) + 1]] <<- list(
type = type, a = A, b = B,
# (I couldn't find a better way to create a nice call string)
call = paste0(call[1], '(', paste0(collapse = ', ', call[2:length(call)]), ')'))
}
.exp_error <- function(expr, exp_msg) {
err_msg <- ''
tryCatch({expr}, error = function(err) {
err_msg <<- err$message
})
.add_test('error', err_msg, exp_msg)
}
.exp_match <- function(expr, regex) {
.add_test('match', expr, regex)
}
.exp_equal <- function(expr, ref) {
.add_test('equal', expr, ref)
}
.exp_false <- function(expr) {
.add_test('false', expr, FALSE)
}
.exp_true <- function(expr) {
.add_test('true', expr, TRUE)
}
# Performing the tests
.exp_match('My name is Siete', 'My name is .*')
.exp_equal(mypackage::sum(5,5), 10) # some imaginary exported functions sum and name.
.exp_match(mypackage::name(), 'Siete')
.exp_false('package:testthat' %in% search())
return(tst)
},
show = TRUE)
# Performing the actual testthat tests:
.run_test_batch <- function(test_outcome) {
test_that(test_outcome$desc, {
for (test in test_outcome$tests) {
# 'test' is a list with the fields 'type', 'a', 'b' and 'call'.
# Where 'type' can contain 'match', 'error', 'true', 'false' or 'equal'.
if (test$type == 'equal') {
with(test, expect_equal(a, b, label = call))
} else if (test$type == 'true') {
expect_true( test$a, label = test$call)
} else if (test$type == 'false') {
expect_false(test$a, label = test$call)
} else if (test$type %in% c('match', 'error')) {
with(test, expect_match(a, b, label = call))
}
}
})
}
.run_test_batch(test_outcome)
When moving the functions to your package you would need the following initialize function too.
tst <- new.env(parent = emptyenv())
tst$desc = ''
tst$tests = list()
.initialize_test <- function(desc) {
tst$desc = desc
tst$tests = list()
}
It works as follows:
An empty list is created: tst
By calling .exp_... functions, tests are added to that list
The list with tests is returned by the function in callr::r
Then we loop over the list and execute every test
I am trying to code the Markov Chain approximation for some control problems.
But I have the following bug in R and I checked similar question in Stackoverflow and still have
no idea how to solve it. Any help will be greatly appreciated.
The bug comes from where I would like to find the minimum value among all of 'u' in a for loop.
To specific, in the uit-for-loop, for each next uit I could get a new single value (I thought) temp and would like to compare this with the temporary minimal stored by a single value variable vmin. That is the idea in the if-else sentence.
It is better to skip the parameter setting and initialization procedure.
#----- parameters ------
xleft=0; xright=10
yleft=0; yright=10
h=0.01
Nx=(xright-xleft)/h
Ns=2
Nu=11; hu=0.2
la=0.1
qMainDiag=c(-0.5,-0.5)
qSubDiag=c(0.5,0.5)
alpha=c(0.2,0.25)
beta=c(0.35,0.2)
a=c(0.6,0.8)
b=c(0.5,0.3)
c=c(0.45,0.5)
d=c(0.65,0.8)
tol=10^(-8)
maxitr=10000
#---- Initialization -----
Vold=array(0,dim=c(Nx+1,Nx+1,Ns))
Vnew=array(0,dim=c(Nx+1,Nx+1,Ns))
Uopt=array(0,dim=c(Nx+1,Nx+1,Ns))
for(r in 1:Ns){
for(i in 1:(Nx+1)){
for(j in 1:(Nx+1)){
Vold[i,j,r]=1
}
}
}
#---- iteration ----
for(n in 1:maxitr){
for(r in 1:Ns){
# inner of O
for(i in 2:Nx){
for(j in 2:Nx){
vInt=0
for(it in 1:(min(i,j)+1)){
vInt=vInt+Vold[i-it+1,j-it+1,r]*0.1*exp(-0.1*(it-1)*h)*h
}
# For each u, want to find the minimum temp value and its u.
for(uit in 1:Nu){
x=xleft+(i-1)*h; y=yleft+(j-1)*h
u=hu*(uit-1)
Xi11=(alpha[r]*x)^2; Xi22=(beta[r]*y)^2
f1=x*(a[r]-b[r]*y+u); f2=y*(-c[r]+d[r]*x+u)
g=1+r*(x+y)*(1+u^2)
Qh=(Xi11+Xi22)+h*(abs(f1)+abs(f2))+h-(h^2)*qMainDiag[r]
dlt=(h*h)/Qh
pforward=0.5*(Xi11+2*h*max(f1,0.0))/Qh
pback=0.5*(Xi11+2*h*max(-f1,0.0))/Qh
pup=0.5*(Xi22+2*h*max(f2,0.0))/Qh
pdown=0.5*(Xi22+2*h*max(-f2,0.0))/Qh
pswitch=(h*h*qSubDiag[r])/Qh
pstay=h/Qh
temp=(1-la*dlt)*(pforward*Vold[i+1,j,r]+pback*Vold[i-1,j,r]
+pup*Vold[i,j+1,r]+pdown*Vold[i,j-1,r]
+pswitch*Vold[i,j,3-r]
+pstay*Vold[i,j,r])+la*dlt*vInt+dlt*g
# find the minimal value (Here is the spot!!!)
if(uit==1){
vmin=temp; umin=u
}else if(temp<vmin){
vmin=temp; umin=u
}
}
Vnew[i,j,r]=vmin
Uopt[i,j,r]=umin
}
}
errormax=max(abs(Vold-Vnew))
print(n)
print(errormax)
Vold=Vnew
if(errormax<tol){
break
}
}
}
I've got a problem with output from S3 function. I try to overload "+" function to act with two vectors like with polynomial parameters. It's my university project. Code is below:
'+.ply' <- function(a,b){
size <- max(length(a$polynomial),length(b$polynomial))
size
aAdd <- a$polynomial
bAdd <- b$polynomial
if (length(aAdd) == size) {
aAdd = aAdd
} else {
length(aAdd) <- size
}
aAdd[is.na(aAdd)] <- 0
if (length(bAdd) == size) {
bAdd = bAdd
} else {
length(bAdd) <- size
}
bAdd[is.na(bAdd)] <- 0
cat("Polynomial of degree ", paste(length(aAdd+bAdd)-1),
" with coefficients ", paste(aAdd+bAdd))
}
Code is working fine, but in return it gives me output
*Polynomial of degree 3 with coefficients 3 4 6 3NULL*
I need to use cat in order to avoid [1] index which occurs while I'm using print, paste combo. I know that there are plenty threads about this problem, but I can't find any sollution for such problem during function overloading. I will be thankful for help.
Is it possible to write a function in R which will hold its execution, giving the users control over the console (while in interactive mode of course), meanwhile recording their inputs, and continuing execution either:
after a certain input has been made
or after a certain output has been made
or a certain duration of time has passed
Example: ask the user a question (without using readline() for the answer)
question <- function() {
message("How much is 2 + 2?")
#let users take control of the console
#continue to next statement only if they input "2+2", or "4" or a minute has passed
#meanwhile record their last input similar to ".Last.Value", e.g.:
startTime <- Sys.time()
timeout <- FALSE
lastInput <- lastInput()
while (eval(parse(text = lastInput)) != 4 & !timeout) {
if (difftime(Sys.time(), startTime, units = "mins") > 1) {
timeout <- TRUE
}
lastInput <- lastInput()
}
if (timeout) {
stop("Sorry, timeout.")
} else {
message("Correct! Let's continue with this function:")
}
}
Where lastInput() is a function which "listens" to user input when it changes.
Obviously the above structure is tentative and won't give me what I want, some way to "listen" or "observe" and only react when the user inputs something to the console.
The final user experience should be:
> question()
How much is 2+2?
> #I'm the user, I can do whatever
> head(mtcars)
> plot(1:10)
> 3
> 2 + 2
[1] 4
Correct! Let's continue with this function:
Am I too optimistic or is there some R magic for this?
Thanks to #parth I have looked at swirl's source code and got acquainted with the addTaskCallback function. From the help file:
addTaskCallback registers an R function that is to be called each time a top-level task is completed.
And so we can make R check the users input ("top-level task") with a specific function, responding accordingly.
But since the swirl code is very "heavy", I think I need to supply a minimal example:
swirllike <- function(...){
removeTaskCallback("swirllike")
e <- new.env(globalenv())
e$prompt <- TRUE
e$startTime <- Sys.time()
cb <- function(expr, val, ok, vis, data=e){
e$expr <- expr
e$val <- val
e$ok <- ok
e$vis <- vis
# The result of f() will determine whether the callback
# remains active
return(f(e, ...))
}
addTaskCallback(cb, name = "swirllike")
message("How much is 2+2?")
}
OK, so the swirllike function evokes the 2+2 question, but it also declares a new environment e with some objects the user needs not know. It then adds the swirllike task callback to the task callback list (or rather vector). This "task callback" holds the cb function which calls the f function - the f function will run with every input.
If you run this, make sure you see the swirllike task callback with:
> getTaskCallbackNames()
[1] "swirllike"
Now the f function is similar to my sketch in the question:
f <- function(e, ...){
if (e$prompt) {
if (difftime(Sys.time(), e$startTime, units = "mins") > 1) {
timeout <- TRUE
stop("Sorry, timeout.")
}
if(!is.null(.Last.value) && .Last.value == 4) {
message("Correct! Let's continue with this function:")
e$prompt <- FALSE
while (!e$prompt) {
#continue asking questions or something, but for this example:
break
}
}
}
return(TRUE)
}
And don't forget to remove the swirllike task callback with:
removeTaskCallback("swirllike")
I have a function that is supposed to return a matrix for further functions to use. I have it reading in a file and doing calculations, but I need the main function to skip to the next file if the current one does not meet the correct formatting. This is how basically how I have it now:
for (file in list.files(directory)) {
for (i in 1:length(var)) {
matrix <- foo('someFile.txt',var[i]) # returns matrix under normal conditions
if (typeof(matrix)) == "logical") { # check if foo returns FALSE
warning(paste0('File ',file, ' is not formatted correctly'))
break # skip to next file if so
}
...
}
}
foo <- function(input,seq)
data <- readLines(input)
if (!data[1] %in% c("first","line","values")) {
return(FALSE)
}
...
return(data)
}
But testing the class matrix returns seems clunky and poor technique. Sorry I don't know how to phrase the question better.