I want to understand if setting a function as the default to another function has caused anyone issues? Is this clearly not best practice?
add_this <- function(a = 1, b = 2){
a + b
}
print_what_we_added <- function(the_sum = add_this()){
paste0("the sum of what we added is ", the_sum)
}
print_what_we_added()
print_what_we_added(5)
Related
I am trying to define a function with a for loop and inside a conditional in R studio. Yesterday I was able with the help of another thread to devise this piece of code. The problem is that I want to sum the vector elements ma for any possible x, so that is inside the function l. This is a simpler case which I am trying to solve to adapt the original model. However, I do not know how to proceed.
ma<-rep(0,20)
l <- function(x, ma) {
for(i in seq_along(ma)) {
if(i %% 2 == 1) {
ma[i] <- i + x
} else {
ma[i] <- 0
}
}
return(ma)
}
My problem is that I would like to have the sum of i+x+0+i+x... for any possible x. I mean a function of the kind for any possible x.
Question:
Can someone explain to me how to implement such a function in R?
Thanks in advance!
I am going to update the original function:
Theta_alpha_s<-function(s,alpha,t,Basis){
for (i in seq_along(Basis)){
if(i%% 2==1) {Basis[i]=s*i^{-alpha-0.5}*sqrt(2)*cos(2*pi*i*t)}
else{Basis[i]=s*i^{-alpha-0.5}*sqrt(2)*sin(2*pi*i*t)}
}
return(Basis)
}
If you don't want to change the values in Basis, you can create a new vector in the function (here result) that you will return:
l = function(s,alpha,t,Basis){
is.odd = which(Basis %% 2 == 1)
not.odd = which(Basis %% 2 == 0)
result = rep(NA, length(Basis))
result[is.odd] = s*is.odd^{-alpha-0.5}*sqrt(2)*cos(2*pi*is.odd*t)
result[not.odd] = s*not.odd^{-alpha-0.5}*sqrt(2)*sin(2*pi*not.odd*t)
#return(result)
return(c(sum(result[is.odd]), sum(result[not.odd])))
}
not sure what I'm doing wrong here. I'm trying to get a cross-validation score for a mixture-of-two-gammas model.
llikGammaMix2 = function(param, x) {
if (any(param < 0) || param["p1"] > 1) {
return(-Inf)
} else {
return(sum(log(
dgamma(x, shape = param["k1"], scale = param["theta1"]) *
param["p1"] + dgamma(x, shape = param["k2"], scale = param["theta2"]) *
1
(1 - param["p1"])
)))
}
}
initialParams = list(
theta1 = 1,
k1 = 1.1,
p1 = 0.5,
theta2 = 10,
k2 = 2
)
for (i in 1:nrow(cichlids)) {
SWS1_training <- cichlids$SWS1 - cichlids$SWS1[i]
SWS1_test <- cichlids$SWS1[i]
MLE_training2 <-
optim(
par = initialParams,
fn = llikGammaMix2,
x = SWS1_training,
control = list(fnscale = -1)
)$par
LL_test2 <-
optim(
par = MLE_training2,
fn = llikGammaMix2,
x = SWS1_test,
control = list(fnscale = -1)
)$value
}
print(LL_test2)
This runs until it gets to the first optim(), then spits out Error in fn(par, ...) : attempt to apply non-function.
My first thought was a silly spelling error somewhere, but that doesn't seem to be the case. Any help is appreciated.
I believe the issue is in the return statement. It's unclear if you meant to multiply or add the last quantity (1 - param["p1"])))) to the return value. Based on being a mixture, I'm guessing you mean for it to be multiplied. Instead it just hangs at the end which throws issues for the function:
return(sum(log(dgamma(x, shape = param["k1"], scale = param["theta1"]) *
param["p1"] +
dgamma(x, shape = param["k2"], scale = param["theta2"]) *
(1 - param["p1"])))) ## ISSUE HERE: Is this what you meant?
There could be other issues with the code. I would double check that the function you are optimizing is what you think it ought to be. It's also hard to tell unless you give a reproducible example we might be able to use. Try to clear up the above issue and let us know if there are still problems.
I am using package fda in particular function fRegress. This function includes another function that is called eigchk and checks if coeffients matrix is singular.
Here is the function as the package owners (J. O. Ramsay, Giles Hooker, and Spencer Graves) wrote it.
eigchk <- function(Cmat) {
# check Cmat for singularity
eigval <- eigen(Cmat)$values
ncoef <- length(eigval)
if (eigval[ncoef] < 0) {
neig <- min(length(eigval),10)
cat("\nSmallest eigenvalues:\n")
print(eigval[(ncoef-neig+1):ncoef])
cat("\nLargest eigenvalues:\n")
print(eigval[1:neig])
stop("Negative eigenvalue of coefficient matrix.")
}
if (eigval[ncoef] == 0) stop("Zero eigenvalue of coefficient matrix.")
logcondition <- log10(eigval[1]) - log10(eigval[ncoef])
if (logcondition > 12) {
warning("Near singularity in coefficient matrix.")
cat(paste("\nLog10 Eigenvalues range from\n",
log10(eigval[ncoef])," to ",log10(eigval[1]),"\n"))
}
}
As you can see last if condition checks if logcondition is bigger than 12 and prints then the ranges of eigenvalues.
The following code implements the useage of regularization with roughness pennalty. The code is taken from the book "Functional data analysis with R and Matlab".
annualprec = log10(apply(daily$precav,2,sum))
tempbasis =create.fourier.basis(c(0,365),65)
tempSmooth=smooth.basis(day.5,daily$tempav,tempbasis)
tempfd =tempSmooth$fd
templist = vector("list",2)
templist[[1]] = rep(1,35)
templist[[2]] = tempfd
conbasis = create.constant.basis(c(0,365))
betalist = vector("list",2)
betalist[[1]] = conbasis
SSE = sum((annualprec - mean(annualprec))^2)
Lcoef = c(0,(2*pi/365)^2,0)
harmaccelLfd = vec2Lfd(Lcoef, c(0,365))
betabasis = create.fourier.basis(c(0, 365), 35)
lambda = 10^12.5
betafdPar = fdPar(betabasis, harmaccelLfd, lambda)
betalist[[2]] = betafdPar
annPrecTemp = fRegress(annualprec, templist, betalist)
betaestlist2 = annPrecTemp$betaestlist
annualprechat2 = annPrecTemp$yhatfdobj
SSE1.2 = sum((annualprec-annualprechat2)^2)
RSQ2 = (SSE - SSE1.2)/SSE
Fratio2 = ((SSE-SSE1.2)/3.7)/(SSE1/30.3)
resid = annualprec - annualprechat2
SigmaE. = sum(resid^2)/(35-annPrecTemp$df)
SigmaE = SigmaE.*diag(rep(1,35))
y2cMap = tempSmooth$y2cMap
stderrList = fRegress.stderr(annPrecTemp, y2cMap, SigmaE)
betafdPar = betaestlist2[[2]]
betafd = betafdPar$fd
betastderrList = stderrList$betastderrlist
betastderrfd = betastderrList[[2]]
As penalty factor the authors use certain lambda.
The following code implements the search for the appropriate `lambda.
loglam = seq(5,15,0.5)
nlam = length(loglam)
SSE.CV = matrix(0,nlam,1)
for (ilam in 1:nlam) {
lambda = 10ˆloglam[ilam]
betalisti = betalist
betafdPar2 = betalisti[[2]]
betafdPar2$lambda = lambda
betalisti[[2]] = betafdPar2
fRegi = fRegress.CV(annualprec, templist,
betalisti)
SSE.CV[ilam] = fRegi$SSE.CV
}
By changing the value of the loglam and cross validation I suppose to equaire the best lambda, yet if the length of the loglam is to big or its values lead the coefficient matrix to singulrity. I recieve the following message:
Log10 Eigenvalues range from
-5.44495317739048 to 6.78194912518214
Created by the function eigchk as I already have mentioned above.
Now my question is, are there any way to catch this so called warning? By catch I mean some function or method that warns me when this has happened and I could adjust the values of the loglam. Since there is no actual warning definition in the function beside this print of the message I ran out of ideas.
Thank you all a lot for your suggestions.
By "catch the warning", if you mean, will alert you that there is a potential problem with loglam, then you might want to look at try and tryCatch functions. Then you can define the behavior you want implemented if any warning condition is satisfied.
If you just want to store the output of the warning (which might be assumed from the question title, but may not be what you want), then try looking into capture.output.
I'm using the ars (Adaptive Rejection Sampling) library to sample a given variable from a concave density distribution.
The thing is that the ars function prints "ifault codes" when something is wrong, but apparently it does not throw any exception.
library(ars)
f<-function(x,mu=0,sigma=1){-1/(2*sigma^2)*(x-mu)^2}
fprima<-function(x,mu=0,sigma=1){-1/sigma^2*(x-mu)}
# mysample<-ars(1,f,fprima,mu=2,sigma=3) # it gives no errors
mysample<-ars(1,f,fprima,mu=2,sigma=3, x=c(2,4)) # bad choice of x
hist(mysample)
The problem is that I call the ars function from python using rpy2 and I need my program to know whether the ars has been able to generate the sample. That is, I would like ars to throw a real exception or return some special value.
How can I catch the error?
Rewrite the code so that the conclusion portions do what you desire. This might be one possible variation of the last portions of the function:
ars2 <- function (n = 1, f, fprima, x = c(-4, 1, 4), ns = 100, m = 3,
emax = 64, lb = FALSE, ub = FALSE, xlb = 0, xub = 0, ...)
{
# leave top portion the same
#......
else {
return( list(msg= "Error in sobroutine sample_...", ifault= sample$ifault))
}
}
}
else {
return( list(msg="\nError in sobroutine initial_...", ifault= initial$ifault))
}
return(mysample)
}
# Then finish up by setting the environment for ars2
environment(ars2) <- environment(ars)
I'm new to R and have some trouble of understanding so called "envirionments" and way to use them properly. What I miss a lot in R language are static variables (like in Java).
I'm writing a program with couple of functions that will need to initialize during first run. To achieve this for each function I've created new environment which will be only accessed by this particular function (for example "f1" will be only accessed from inside "myfunction1").
What I don't like about my solution is that there is some additional code outside of function body and it's not too readable. Is there any simpler way to achieve the same? And if yes then it would be nice if you could provide me with modified example to show me how it works. Thank you.
f1 <- new.env()
f1$initialized <- FALSE
f1$o <- NULL
f1$length <- NULL
f1$compute
myfunction1 <- function(x) {
if(f1$initialized == FALSE){
f1$initialized <- TRUE
f1$compute <- 2*pi^2+3
}
if(is.null(f1$length) || f1$length!=length(x)){
f1$length <- length(x)
if(f1$length==2) {f1$o<-read.table("data_1.txt")}
else {f1$o<-read.table("data_2.txt")}
}
print("Lets print something!")
return(f1$o * f1$compute * x + 1000)
}
If you are familiar with Java then maybe using RefrenceClasses would be a good way to go. This seems to do what you are looking for:
myclass <- setRefClass('myclass', fields = list(initilized = 'logical',
o = 'data.frame',
len = 'numeric',
compute = 'numeric'))
#constructor
myclass$methods(initialize = function(initialized, len){
initilized <<- initialized
len <<- len
})
#method
myclass$methods(myfunction1 = function(x){
if(initilized == FALSE){
initilized <<- TRUE
compute <<- 2*pi^2+3
}
if(is.null(len) || len != length(x)){
len <<- length(x)
if(len==2) {o <<- read.table("data_1.txt")}
else {o <<- read.table("data_2.txt")}
}
print("Lets print something!")
return(o * compute * x + 1000)
})
obj <- myclass$new(FALSE, 0)
obj$myfunction1(2)
Check out ?ReferenceClasses for information on what's going on here (much more OOP styled and has some support for class inheritance, which sounds like what you want anyway).