My young son and I were playing a board game called Snails Pace. Simple enough, so I sat down to show him the game on the R-console.
Helper function
num.round = function(n, by=5)
{
byidx = (n %% by == 0); # these already are indexed well
new = by * as.integer((n + by) / by);
res = n;
res[!byidx] = new[!byidx];
res;
}
Primary function
snails.pace = function(moves = 200, finish.line = 8,
snail.x = NULL,
snail.y = NULL,
snail.col = NULL
)
{
if(is.null(snail.x)) { snail.x = 0*(1:6); }
if(is.null(snail.y)) { snail.y = 1*(1:6); }
if(is.null(snail.col)) { snail.col = c("orange", "blue", "pink", "green", "yellow", "red"); }
snail.rank = 0*snail.x;
crank = 1; # current rank
move.number = 0;
snails.plot = function(snail.x, snail.y, snail.rank, move.number, moves, finish.line, crank)
{
xmax = max(10, max(snail.x) );
ymax = max(8, max(snail.y) );
plot(snail.x, snail.y,
col=snail.col,
pch=16, cex=5,
xlim=c(0, num.round(xmax, 5) ),
ylim=c(0, num.round(ymax, 4) ),
axes=FALSE,
frame.plot=FALSE,
xlab="", ylab="",
main=paste0("Move #", move.number, " of ", moves)
);
#axis(gr.side("bottom"));
axis(1);
has.rank = (snail.rank != 0);
snails.lab = paste0(snail.x, "*", snail.rank);
snails.lab[!has.rank] = snail.x[!has.rank];
text(snail.x, y=snail.y, labels=snails.lab, col="black");
abline(v = finish.line, col="gray", lty="dashed");
}
snails.update = function(snail.x, snail.y, snail.rank, move.number, moves, finish.line, crank)
{
x = readline(prompt="Press [enter] to continue, [ESC] to quit");
n = sample(1:6, 1);
snail.x[n] = 1 + snail.x[n];
if( (snail.rank[n] == 0) && (snail.x[n] >= finish.line) )
{
snail.rank[n] = crank;
crank = 1 + crank;
# update to MAIN environment
assign("snail.rank", snail.rank, envir=parent.frame() );
assign("crank", crank, envir=parent.frame() );
}
snail.x;
}
snails.plot(snail.x, snail.y, snail.rank, move.number, moves, finish.line, crank);
while(move.number < moves)
{
move.number = 1 + move.number;
snail.x = snails.update(snail.x, snail.y, snail.rank, move.number, moves, finish.line, crank);
snails.plot(snail.x, snail.y, snail.rank, move.number, moves, finish.line, crank);
}
}
Game play
snails.pace();
Question: how to scope internal functions within MAIN environoment?
The MAIN function is snails.pace(). You will notice in the internal function snails.update, I update two variables and assign them back to the MAIN scope using assign.
Is there a way at the MAIN level I can define all the variables and just USE them within all internal functions without having to assign them back or returning the updating values?
As you can see in my CODE, I call all of the variables into the functions and either "back assign" or return any changes. I would prefer to just set a new env() or something and have MAIN work like R-Global seems to. Any suggestions on how to do that?
That is, my internal functions would not pass anything in: snails.plot = function() and snails.update = function() AS they would get the LOCAL environment variables (defined as within MAIN defined as snails.pace()). And ideally update the LOCAL environment variables by updating the value within the internal function.
Update
So it appears that I can drop the function passing. See:
snails.pace2 = function(moves = 200, finish.line = 8,
snail.x = NULL,
snail.y = NULL,
snail.col = NULL
)
{
if(is.null(snail.x)) { snail.x = 0*(1:6); }
if(is.null(snail.y)) { snail.y = 1*(1:6); }
if(is.null(snail.col)) { snail.col = c("orange", "blue", "pink", "green", "yellow", "red"); }
snail.rank = 0*snail.x;
crank = 1; # current rank
move.number = 0;
snails.plot = function()
{
xmax = max(10, max(snail.x) );
ymax = max(8, max(snail.y) );
plot(snail.x, snail.y,
col=snail.col,
pch=16, cex=5,
xlim=c(0, num.round(xmax, 5) ),
ylim=c(0, num.round(ymax, 4) ),
axes=FALSE,
frame.plot=FALSE,
xlab="", ylab="",
main=paste0("Move #", move.number, " of ", moves)
);
#axis(gr.side("bottom"));
axis(1);
has.rank = (snail.rank != 0);
snails.lab = paste0(snail.x, "*", snail.rank);
snails.lab[!has.rank] = snail.x[!has.rank];
text(snail.x, y=snail.y, labels=snails.lab, col="black");
abline(v = finish.line, col="gray", lty="dashed");
}
snails.update = function()
{
x = readline(prompt="Press [enter] to continue, [ESC] to quit");
n = sample(1:6, 1);
snail.x[n] = 1 + snail.x[n];
if( (snail.rank[n] == 0) && (snail.x[n] >= finish.line) )
{
snail.rank[n] = crank;
crank = 1 + crank;
# update to MAIN environment
assign("snail.rank", snail.rank, envir=parent.frame() );
assign("crank", crank, envir=parent.frame() );
}
snail.x;
}
snails.plot();
while(move.number < moves)
{
move.number = 1 + move.number;
snail.x = snails.update();
snails.plot();
}
}
#MrFlick is correct about the lexical scoping, if I understand the above correctly. If an internal updates something from MAIN, it has to assign it back to MAIN I guess <<- or assign ... parent. Is there not a way to tell the internal SUBFUNCTIONS to SCOPE at the same level of MAIN?
There are two completely different concepts called "parent" in R: the parent.frame() of a call, and the parent.env() of an environment.
parent.frame() walks up the chain of the stack of calls. If you have a recursive function that calls itself, it will appear multiple times in that chain.
In general, it's dangerous to use parent.frame(), because even if the context in which you use it now makes it clear which environment will be the parent.frame(), at some future time you might change your program (e.g. make the internal function into a recursive one, or call it from another internal function), and then parent.frame() will refer to something different.
The parent.env() function applies to an environment; parent.env(environment()) gives you the enclosing environment of the current one. If you call parent.env(environment()) it will always refer to the environment where your current function was defined. It doesn't matter how you called it, just how you defined it. So you always know what will happen if you assign there, and it's much safer in the long term than using parent.frame().
The <<- "super-assignment" works with enclosing environments, not the stack of calls. If you do var <<- value, then as long as you are sure that var was defined in the enclosing function, you can be sure that's what gets modified.
One flaw in R is that it doesn't enforce the existence of var there, so that's why some people say <<- is "sloppy". If you accidentally forget to define it properly, or spell it wrong, R will search back through the whole chain of environments to try to do what you asked, and if it never finds a matching variable, it will do the assignment in the global environment. You almost never want to do that: keep side effects minimal.
So, to answer the question "Is there a way at the MAIN level I can define all the variables and just USE them within all internal functions without having to assign them back or returning the updating values?": as you found in your edit, the nested function can read the value of any variable in the MAIN function without requiring any special code. To modify those variables, be sure both snail.rank and crank are defined in MAIN, then use <<- in the nested function to assign new values to them.
To have a function f defined within another function main such that f has the same scope as main surround the entire body of f with eval.parent(substitute({...})) like this:
main <- function() {
f <- function() eval.parent(substitute({
a <- a + 1
b <- 0.5
}))
a <- 1
f()
f()
10 * a + b
}
main()
## [1] 30.5
The gtools package has defmacro which allows the same thing and uses the same technique internally. Also see the wrapr package.
Related
I would like to use multiple constructors in my R S4 class.
I have an object that has three slots. To make that object, sometimes I want to just give the values for the three slots outright. But sometimes I'd like to provide a matrix, and I have a function that can take a matrix and return what those three slots should be.
At first, it seems like I could write a function as a constructor. So I could write objectFromMatrix(matrix) --> object with three slots. The problem is that I also have sub-classes that inherit from that main class, and I want to be able to use that constructor with them as well.
So I could just write functions as extra constructors for each of the subclasses, but that would be a bit tedious and not super OO-like.
To make my problem a little more tangible, I'll try to write a minimal example below. I'll write it in Java, but I'm a bit rusty so let me know if it doesn't make sense.
Desired structure, in Java:
// An abode is a place where you live and it has a size
class Abode {
int size = 1;
// Main constructor that just assigns args to fields
Abode(int size) {
this.size = size;
}
// Alternative constructor that takes in a different datatype
// and computes args to assign to fields
Abode(string description) {
if(description eq "Large") {
this.size = 5;
}
if(description eq "Small") {
this.size = 1;
}
}
// To keep it simple, a house is just an abode with a name
class House extends Abode {
String name;
House(int size, String name) {
super(size);
this.name = name;
}
House(string size, String name) {
super(size);
this.name = name;
}
}
This implementation works nicely because I can call Abode("big") or House("big", "Casa de me"), and both of those get passed to the extra constructor I built in the Abode class.
Keeping up with the house analogy, this is the best I've been able to do in R:
# An abode is a place you live and it has a size
setClass("Abode",
slots =
list(size = "numeric")
)
# Alternative constructor that takes in a different datatype
# and computes args to assign to fields
abode_constructor_2 <- function(sizeString) {
if (sizeString == "big") {return new("Abode", size = 5)}
if (sizeString == "small") {return new("Abode", size = 1)}
}
# A house is an abode with a name
setClass("House",
slots =
list(name = "string"),
contains = "Abode"
)
# I already defined this constructor but I have to do it again
house_constructor_2 <- function(sizeString, name) {
if (sizeString == "big") {return new("House", size = 5, name = name)}
if (sizeString == "small") {return new("House", size = 1, name = name)}
}
In case it helps, here is a minimal example of the real context where this problem is coming up. I define an extra constructor for the Sensor class, sensor_constructor_2, as a function. But then, when I have a class that inherits from Sensor, I have to make that constructor over again.
# A sensor has three parameters
setClass("Sensor",
slots =
list(Rmin = "numeric", Rmax = "numeric", delta = "numeric")
)
# I also like to make sensors from a matrix
sensor_constructor_2 <- function(matrix) {
params <- matrix_to_params(matrix)
return (new("Sensor", Rmin = params[1], Rmax = params[2], delta = params[3]))
}
# A redoxSensor is just a sensor with an extra field
setClass("redoxSensor",
slots =
list(e0 = "numeric"),
contains = "Sensor"
)
# Goal: make this extra constructor unnecessary by making sensor_constructor_2 a property of the sensor class
extraConstructor_redox <- function(matrix, e0) {
params <- matrix_to_params(matrix)
return (new("redoxSensor", Rmin = params[1], Rmax = params[2], delta = params[3]), e0 = e0)
}
There is no reason why you can't do this with one S4 constructor by using default arguments and a little extra logic, along the lines of
setClass("Abode",
slots = list(size = "numeric")
) -> Abode
setClass("House",
slots = list(name = "character"),
contains = "Abode"
) -> House
createDwelling <- function(size=0,name,sizeString){
if(!missing(sizeString)){
if(sizeString == "Large") size <- 5
else if(sizeString == "Small") size <- 1
else stop("invalid sizeString")
}
if(missing(name)) return(Abode(size=size))
else return(House(size=size,name=name))
}
example usage:
> createDwelling(size=3)
An object of class "Abode"
Slot "size":
[1] 3
> createDwelling(sizeString="Small")
An object of class "Abode"
Slot "size":
[1] 1
> createDwelling(sizeString="Small",name="my house")
An object of class "House"
Slot "name":
[1] "my house"
Slot "size":
[1] 1
I'm trying to write a function to compute sample sizes in R.
The function uses a couple of smaller functions. I'd like to pass arguments into the smaller functions using the dots. Here is my function so far:
log_reg_var<-function(p){
if(p<=0|p>=1) stop('p must be between 0 and 1')
var<-1/(p*(1-p))
return(var)
}
samplesize<-function(method_name, beta, sigma_x, mult_cor, power= 0.8,fpr = 0.05,...){
if(method_name=='linear regression'){
var_func <- lin_reg_var
}
else if(method_name=='logistic regression'){
var_func <- log_reg_var
}
else if(method_name=='cox regression'){
var_func <- cox_reg_var
}
else if(method_name=='poisson regression'){
var_func <- pois_reg_var
}
else{
stop('method_name not recognized. method_name accepts one of: "linear regression",
"logistic regression","cox regression", or "poisson regression"')
}
top = (qnorm(1-fpr/2) + qnorm(power))^2
bottom = (beta*sigma_x)^2*(1-mult_cor)
n = (top/bottom)*var_func(...)
return(ceiling(n))
}
I should be able to do
samplesize(method_name = 'logreg',1,1,0,p=0.5)
>>>32
But instead I am thrown the following error:
Error in var_func(...) : argument "p" is missing, with no default
Clearly there is something wrong with me passing p through the dots, but I'm not sure what is wrong.
What is my problem here?
You need to add the additional parameter p as an argument and you need to pass it into your log_reg_var() function. You also have to be careful with some other syntax:
log_reg_var<-function(p){
if(p<=0|p>=1) stop('p must be between 0 and 1')
var<-1/(p*(1-p))
return(var)
}
# specify that you pass a parameter `p`
samplesize<-function(method_name, beta, sigma_x, mult_cor, power= 0.8,fpr = 0.05, p, ...){
# Initialize `var_func` to a NULL value
var_func = NULL
if(method_name=='linear regression'){
var_func <- lin_reg_var(p)
}
else if(method_name=='logistic regression'){
# pass parameter `p` into log_reg_var since there is no default
var_func <- log_reg_var(p)
}
else if(method_name=='cox regression'){
var_func <- cox_reg_var(p)
}
else if(method_name=='poisson regression'){
var_func <- pois_reg_var(p)
}
else{
stop('method_name not recognized. method_name accepts one of: "linear regression",
"logistic regression","cox regression", or "poisson regression"')
}
top = (qnorm(1-fpr/2) + qnorm(power))^2
bottom = (beta*sigma_x)^2*(1-mult_cor)
n = (top/bottom)*var_func
return(ceiling(n))
}
> samplesize(method_name ='logistic regression', 1, 1, 0, p=0.5)
[1] 32
Just as a test:
myclass = setRefClass("myclass",
fields = list(
x = "numeric",
y = "numeric"
))
myclass$methods(
dfunc = function(i) {
message("In dfunc, I save x and y...")
obj = .self
base::save(obj, file="/tmp/obj.rda")
}
)
myclass$methods(
print = function() {
if (.self$x > 10) {
stop("x is too large!")
}
message(paste("x: ", .self$x))
message(paste("y: ", .self$y))
}
)
myclass$methods(
initialize = function(x=NULL, y=NULL, obj=NULL) {
if(is.null(obj)) {
.self$x = x
.self$y = y
}
else {
.self$x = obj$x
.self$y = obj$y
}
}
)
myclass$methods(
finalize = function() {
message("I am finalizing this thing...")
}
)
Then try to create and remove an object:
u = myclass(15, 6)
u$print()
rm(u)
The finalize function is not called at all...
When you call rm you just remove the object reference from the enviroment, but you don't destroy the element.
That is the work of the garbage collector that is designed to automatically destroy objects when they have nomore reference (like in this case). Anyway, the garbage collector is triggered by some special events (e.g. too much memory used etc.), so it is not automatically invoked when you call rm (it will be probably called later later).
Anyway, you can force the garbage collector, even if this is usually discouraged, by calling gc().
u = myclass(15, 6)
rm(u)
gc()
# > I am finalizing this thing...
As you can see by running the above code, your finalize method is indeed called after gc()
Is it possible to do something like this somehow with pairs or a similar function?
var = "" #initialization
panel.pearson <- function(x, y, ...) {
horizontal <- (par("usr")[1] + par("usr")[2]) / 2;
vertical <- (par("usr")[3] + par("usr")[4]) / 2;
cor = cor.test(x,y)
cor.p = cor$p.value
cor.r = cor$estimate
cor.p = round(cor.p, digits = 2)
cor.r = round(cor.r, digits = 2)
stars = ifelse(cor.p < .001, "***", ifelse(cor.p < .01, "** ", ifelse(cor.p < .05, "* ", " ")))
format_r_p = paste(cor.r, stars, sep="")
text(horizontal, vertical, format_r_p, cex=2)
var = c(var, format_r_p)
}
pairs(crime, upper.panel=panel.pearson )
var would output all the format_r_p values.
It’s possible but it’s a really, really bad idea in general: functions should not mutate global state.
So instead, isolate the modification to be local instead of global:
var = ''
pairs(crime, upper.panel = function (x, y, ...) {
result = panel.pearson(x, y, ...)
var <<- c(var, result)
result
})
Now, instead of making panel.pearson modify any global magic variables, we use an anonymous function in the scope of the call to pairs to modify a variable in the scope of the call to pairs, i.e. locally.
To modify this variable from inside the anonymous function, we use <<- instead of the normal assignment.
This is my code.
beta1 = function(a,b,t) { beta(a+(1/t),b) }
beta2 = function(a,b,t) { beta(a+(2/t),b) }
eb11 = function(a,b,t) { beta2(a,b,t)/beta(a,b) }
eb12 = function(a,b,t) { (beta1(a,b,t)-beta2(a,b,t))/beta(a,b) }
eb22 = function(a,b,t) { 1 + (beta2(a,b,t)-2*beta1(a,b,t))/beta(a,b) }
eb11r11 = function(a,b,t) { beta2(a,b,t)*beta(a,b)/beta1(a,b,t)^2 }
eb12r12 = function(a,b,t) { (beta1(a,b,t)-beta2(a,b,t))*beta(a,b)/beta1(a,b,t)/(beta(a,b)-beta1(a,b,t)) }
eb22r22 = function(a,b,t) { (beta(a,b)^2 + (beta2(a,b,t)-2*beta1(a,b,t))*beta(a,b))/(beta(a,b)-beta1(a,b,t))^2 }
gbetloglik = function(a,b,t) {
loglik = n1*log(eb11r11(a,b,t)) + n2*log(eb12r12(a,b,t)) + n3*log(eb22r22(a,b,t))
return(-loglik)
}
abt = optim(c(0.5,0.5,1),gbetloglik,lower=c(0.001,0.001,0.001),method="L-BFGS-B")$par
What I'd like to do is to find a,b, and t that maximize 'gbetloglik' function.
But I got this error.
Error in 2/t : 't' is missing
It seems that the third argument of function 'beta2' is missing. When I enter three numbers directly in gbetloglik function, it works well. The problem occurs only in optim() function.
Does anyone have any idea?
It looks like you are misinterpreting the first argument of the optim function. The first argument simply supplies initial values for the 1 arguments being optimized. In your case this is supplying 3 initial guesses for one of the arguments to gbetloglik. This call will work:
abt = optim(0.5,gbetloglik,lower=c(0.001,0.001,0.001),method="L-BFGS-B", b=0.5, t= 0.5)$par
but won't optimize across all three arguments, it will simply optimize a given b and t. To optimize across all arguments you will need to install an external package from here. Here is an example from nlmrt:
ydat = c(6.308, 6.94, 9.638, 12.866, 17.069, 23.192, 31.443, 37.558, 51.156, 64.948, 77.995, 91.972)
tdat = seq_along(ydat)
start1 = c(b1=1, b2=1, b3=1)
eunsc = y ~ b1/(1+b2*exp(-b3*tt))
anlxb1g =try(nlxb(eunsc, start=start1, trace=FALSE, data=data.frame(y=ydat, tt=tdat)))
print(anlxb1g)
anlxb1g$coefficients