I am trying to write my first function in R to calculate emittance using Plank's function for different temperatures. I can do it manually as below for temperatures from 200 to 310 K.
pi <- 3.141593
h <- 6.626068963e-34
c <- 2.99792458e+8
lambda <- 4 * 1e-6
k <- 1.38e-23
t <- c (200:310)
a <- (2*pi*(c^2)*h)/(lambda^5)
b <- exp((h*c)/(lambda*k*t))
B <- a * (1/(b-1))
Where B is the vector of values I want.
Now here is an effort to write a function in R:
P_function <- function(t, pi = 3.141593, h = 6.626068963e-34, c = 2.99792458e+8,
lambda = 4 * 1e-6, k = 1.38e-2) {
((2*pi*(c^2)*h)/(lambda^5)) *((1/(exp((h*c)/(lambda*k*t))-1)))
}
Now for different values of t (200-300K), how do I implement this function?
Couple of problems. First, pi is already a defined constant at better precision than you are using.
> rm(pi) # remove your copy
> pi
[1] 3.141593 # default for console printing is only 8 digits
> print(pi, digits=18)
[1] 3.14159265358979312 # but there is more "depth" to be had
Second, it makes no sense to put scientific constants in the parameter list. Since they're constant they can be defined in the body. Parameter lists are for items that might vary from situation to situation.
newPfun <- function(t) { h <- 6.626068963e-34
c <- 2.99792458e+8
lambda <- 4 * 1e-6
k <- 1.38e-23
a <- (2*pi*(c^2)*h)/(lambda^5) #pi is already defined
b <- exp((h*c)/(lambda*k*t))
B <- a * (1/(b-1))
return(B) }
This is just your original code "packaged" to accept a vector of temperatures. (And I'm pretty sure that's not the right spelling the scientist's name.)
Not sure where your second function is flawed. Perhaps a mismatched parenthesis. After trying to duplicate the results with a single expression and failing multiple times, I'm now wondering if it's really a problem with numerical overflow (or underflow).
Related
I'm trying to write a function that takes in p1 probabilities for Mahalanobis distances and returns p2 probabilities. The formula for p2, along with a worked example is given at on the IBM website. I have written a function (below) that solves the problem, and allows me to reproduce the p2 values given in the worked example at the aforementioned webpage.
p1_to_p2 <- function(p1,N) {
p2 <- numeric(length(p1))
for (i in 1:length(p1))
{
k <- i;
p1_value <- p1[i];
start_value <- 1;
while (k >= 1)
{
start_value = start_value - choose(N,N-k+1) * (1-p1_value)^(N-k+1) * (p1_value)^(k-1)
k <- k-1;
}
p2[i] <- start_value;
}
return(p2)
}
p1 <- c(.0046132,.0085718,.0390278,.0437704,.0475222)
N <- 73
p1_to_p2(p1,N)
Although the function works, it's been suggested to me by a colleague that it's inefficient/poorly written as it's not vectorized. This is indeed potentially relevant since in general we will be converting a lot more than just 5 p1 values to p2 values.
I have some limited experience vectorizing code, but I am wondering if a vectorized solution is possible in this context since within the loop the variable start_value constantly needs to update itself. If vectorization is not possible, is there some other way I should improve the code so that it works better?
Here is one way to do it, Breaking the steps here can help(Please read the comments):
#Input:
N <- 73
p1 <- c(.0046132,.0085718,.0390278,.0437704,.0475222)
n <- N:(N-length(p1)+1)
# code:
mahalanobis_dist = function(x=x,n){
m = max(n)
max_min = Reduce(`*`,c(1, n[-length(n)]), accumulate = TRUE)
acc = c(1, Reduce(`*`, seq_along(n), accumulate = TRUE)[-length(n)])
comns = max_min/acc
exp <- comns*((1 - x)**n)*(x**(m - n))
return(1- sum(exp))
} ## the calculation of Mahalanobis distances
## This is just an iterator for each of the sequences we have to run the above function
ls <- lapply(n, function(x)(max(n):x))
## creating a list of iterators
## applying mapply, mapply or Map can iterate multiple inputs of the function,
## here the input p1 and ls , p1 is your input points, ls is the iterator created above
mapply(mahalanobis_dist,p1, ls)
## Applying the function on each iterators
#Output:
#> mapply(mahalanobis_dist,p1, ls)
#[1] 0.2864785 0.1299047 0.5461263 0.3973690
#[5] 0.2662369
Note:
Also, one can join the last two steps like below, with one function and correct iteration this can be achieved:
mapply(mahalanobis_dist,p1, lapply(n, function(x)(max(n):x)))
I want to minimize function (log(37/1809)-log((1+a)/(1+aexp(1)^(b(99-79)))))^2 (and find a and b values when value of function is minimum) but i did not get the answer i know should be correct.
I write this code in R:
fixed=c(FALSE,FALSE)
params<- fixed
funkcija_S1 <- function(p) {
params[!fixed] <- p
a <- params[1]
b <- params[2]
S1<-(log(37/1809)-log((1+a)/(1+a*exp(1)^(b*(99-79)))))^2
}
airb<-optim(c(a=0, b=1), funkcija_S1)
airb=airb[1]
airb<-as.numeric(unlist(airb))
a=airb[1]
b=airb[2]
The answer I get is a = 0.82813..... and b = 0.23351....
The answer i SHOULD get is a = 0.803228 and b = 0.234345.
Values of a and b are changing depending on what i write as primary a and b values in this line:
airb<-optim(c(a=0, b=1), funkcija_S1)
Is it possible not to specify the primary values in this line? Or maybe there is another way to minimize this equation?
I need to find derivative of function defined like
f<-function(x){x^2}
After that I want to have a derivative function g, such that I would be able to get something like:
g(5) # entered
10 # answer
without Yacas or similar heavy software. I find it surprising that R can find the derivative of x^2, but there is no way to differentiate f<-function(x){x^2}.
I have tried to do something like this:
f<-function(x){x^2}
g<-Deriv(f,"x")
I got an error:
Error in list2env(list(), NULL, <environment>) :
names(x) must be a character vector of the same length as x
I have also tried this:
> f1<-'x^2'
> g<-Deriv(f1,"x")
> g
#Result:
"2*x"
Can I transform my function f to a one like f1 and reverse the process?
Is there another way?
You could define your function as an expression:
f <- expression(x^2)
Such an expression can be treated like a function by using eval():
#> eval(f,list(x=2))
#[1] 4
In this case, the advantage of an expression instead of a function is that the former allows for the use of symbolic calculus to obtain the first derivative:
g <- D(f,"x")
#> g
#2 * x
To evaluate this expression of the first derivative (more precisely its class is a call), you can use the same syntax as was done before for f:
#> eval(g,list(x=5))
#[1] 10
Assuming a one line body and a function of a single variable x:
f <- function(x) x^2
g <- f
body(g) <- D(body(f), "x")
giving:
> g
function (x)
2 * x
I have made the following function I would like to make a 3-dimensional image of using the function "persp", therefore I use the function outer, to get the value of the function for each combination of a and b, but this make an Error.
So my code is:
a<- seq(from=0, to=5,by=0.25)
b<- seq(from=0.1, to=2,by=0.1)
Rab <- function(a,b){
r <- matrix(ncol = 1, nrow = 4)
for (p in seq(from=0, to=4,by=1)){
g <- ifelse(a>=0 & a<1-1/p & p >b, a*p,
ifelse(a>=0 & a<1-1/b & p< b, -1+(a+1/b),
ifelse(a > 1-1/max(p,b),-1+p,NA)))
w <- p
r[w] <- g
}
return(r)
}
q <- outer(a,b,Rab)
And then I get the following Error and warning messages, which I don't understand.
Error in outer(a, b, Rab) :
dims [product 420] do not match the length of object [4]
In addition: Warning messages:
1: In r[w] <- g :
number of items to replace is not a multiple of replacement length
2: In r[w] <- g :
number of items to replace is not a multiple of replacement length
3: In r[w] <- g :
number of items to replace is not a multiple of replacement length
4: In r[w] <- g :
number of items to replace is not a multiple of replacement length
I have tried to read about it, and I think it is because I have constructed the function Rab wrong, but I don't know how to correct it.
Any help is appreciated.
You are right that your Rab function is wrong. The documentation of outer says
X and Y must be suitable arguments for FUN. Each will be extended by rep to length the products of the lengths of X and Y before FUN is called.
FUN is called with these two extended vectors as arguments (plus any arguments in ...). It must be a vectorized function (or the name of one) expecting at least two arguments and returning a value with the same length as the first (and the second).
So in your example a and b are extended to both have length length(a) * length(b), which happens to be 420 in your case. your function Rab should then return a vector of the same length.
In Rab you compute a vector g that has the correct length and would be suitable as a return value. Instead of returning this vector you try to assign it to an entry in the matrix r. Note that this matrix is defined as
r <- matrix(ncol = 1, nrow = 4)
and can't hold vectors of length 420 in either its rows or columns (this is what the warning messages are about). You lose all but the first element of your vector g in the process. You then go on to re-compute g with a slightly different set of parameters, which brings us to the next problem. These computations happen in a loop that is defined like this:
for (p in seq(from=0, to=4,by=1)){
## compute g ...
r[p] <- g
}
You seem to expect this loop to be executed four times but it is actually run five times for values of p equalling 0, 1, 2, 3 and 4. This means that the first g is assigned to r[0], which R silently ignores. Of course when you then try to return r none of this really matters because it only has length 4 (rather than 420) and this triggers an error.
I'm not convinced that I really understand what you are trying to do but the following might be a step in the right direction.
Rab <- function(a, b, p){
ifelse(a>=0 & a<1-1/p & p >b, a*p,
ifelse(a>=0 & a<1-1/b & p< b, -1+(a+1/b),
ifelse(a > 1-1/max(p,b),-1+p,NA)))
}
This will compute the g from your function once for a fixed value of p and return the result. You'd call this like so (for p=0):
q <- outer(a, b, Rab, 0)
If you want to call it for a number of different p you can do something like
q <- lapply(0:3, function(x,y,f, p) outer(x, y, f, p), x=a, y=b, f=Rab)
This would call Rab with p = 0, 1, 2 and 3 (I'm guessing that's what you want, adjust as required).
Under what circumstances does the following example return a local x versus a global x?
The xi'an blog wrote the following at http://xianblog.wordpress.com/2010/09/13/simply-start-over-and-build-something-better/
One of the worst problems is scoping. Consider the following little gem.
f =function() {
if (runif(1) > .5)
x = 10
x
}
The x being returned by this function is randomly local or global. There are other examples where variables alternate between local and non-local throughout the body of a function. No sensible language would allow this. It’s ugly and it makes optimisation really difficult. This isn’t the only problem, even weirder things happen because of interactions between scoping and lazy evaluation.
PS - Is this xi'an blog post written by Ross Ihaka?
Edit - Follow up question.
Is this the remedy?
f = function() {
x = NA
if (runif(1) > .5)
x = 10
x
}
This is only a problem if you write functions that do not take arguments or the functionality relies on the scoping of variables outside the current frame. you either i) pass in objects you need in the function as arguments to that function, or ii) create those objects inside the function that uses them.
Your f is coded incorrectly. If you possibly alter x, then you should pass x in, possibly setting a default of NA or similar if that is what you want the other side of the random flip to be.
f <- function(x = NA) {
if (runif(1) > .5)
x <- 10
x
}
Here we see the function works as per your second function, but by properly assigning x as an argument with appropriate default. Note this works even if we have another x defined in the global workspace:
> set.seed(3)
> replicate(10, f())
[1] NA 10 NA NA 10 10 NA NA 10 10
> x <- 4
> set.seed(3)
> replicate(10, f())
[1] NA 10 NA NA 10 10 NA NA 10 10
Another benefit of this is that you can pass in an x if you want to return some other value instead of NA. If you don't need that facility, then defining x <- NA in the function is sufficient.
The above is predicated on what you actually want to do with f, which isn't clear from your posting and comments. If all you want to do is randomly return 10 or NA, define x <- NA.
Of course, this function is very silly as it can't exploit vectorisation in R - it is very much a scalar operation, which we know is slow in R. A better function might be
f <- function(n = 1, repl = 10) {
out <- rep(NA, n)
out[runif(n) > 0.5] <- repl
out
}
or
f <- function(x, repl = 10) {
n <- length(x)
out <- rep(NA, n)
out[runif(n) > 0.5] <- repl
out
}
Ross's example function was, I surmise, intentionally simple and silly to highlight the scoping issue - it should not be taken as an example of writing good R code, nor would it have been intended as such. Be aware of the scoping feature and code accordingly, and you won't get bitten. You might even find you can exploit this feature...
The 'x' is only declared in the function if the 'if' condition is true, so if 'runif(1)>.5' then the second mentioning of the x will make the function return your local x (10), otherwise it will return a globally defined 'x' (and if 'x' is not defined globally then it will fail)
> f =function() {
+ if (T)
+ x = 10
+ x
+ }
> f()
[1] 10
> f =function() {
+ if (F)
+ x = 10
+ x
+ }
> f()
Error in f() : Object 'x' not found
> x<-77
> f()
[1] 77