dim() Error in outer - r

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).

Related

Writing a function in R to solve Plank's equation

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).

Error number of items to replace is not a multiple of replacement length

I realize this error is touched on in other posts, but I still can't figure out how it applies to my particular situation. I have the following code.
myfun <- function(x, g, o){
y <- x
fs <- ((g-1)/o) * (o*g/((g-1)*(1+o)))^g
xb <- o/(g-1)
y[x>=xb] <- ((x+o)/(1+o))^g
y[x<xb] <- x*fs
return(y)
}
x <- seq(0,1,length=5)
y <- myfun(x, 1.5, 0.05)
My code is returning the following errors.
Warning messages:
1: In y[y >= xb] <- ((x + o)/(1 + o))^g :
number of items to replace is not a multiple of replacement length
2: In y[y < xb] <- x * fs :
number of items to replace is not a multiple of replacement length
In addition the results seem to be incorrect.
I expect
y =
0 0.152720709664243 0.379105500429200 0.665044998814453 1
but get :
y =
[1] 0.00000000 0.01039133 0.15272071 0.37910550 0.66504500
This leads me to believe I'm doing something incorrect in my indexing, or there's something going on with the math on the vector x. Any help would be much appreciated.
By construction, x is of length 5, such that y and ((x+o)/(1+o))^g are of length 5 as well.
However, the test x>=xb is only true for 4 elements out of 5, such that y[x>=xb] is 4 elements long. Therefore your assignement y[x>=xb] <- ((x+o)/(1+o))^g clashes because the two elements are not of the same length.
I guess what you want to do is something like
y[x>=xb] <- ((x[x>=xb]+o)/(1+o))^g
y[x<xb] <- x[x<xb]*fs
I get
>y
[1] 0.0000000 0.1527207 0.3791055 0.6650450 1.0000000
which is close from what you want, I'll let you figure that out.

fminsearch on a single variable

Using R's help page example on fminsearch as a starting point:
# Rosenbrock function
rosena <- function(x, a) 100*(x[2]-x[1]^2)^2 + (a-x[1])^2 # min: (a, a^2)
fminsearch(rosena, c(-1.2, 1), a = sqrt(2))
# x = (1.414214 2.000010) , fval = 1.239435e-11
I want to evaluate something like this but with only one variable such as:
rosena <- function(x, a) 100*(x[1]-x[1]^2)^2 + (a-x[1])^2
but when I run
fminsearch(rosena, c(1), a = sqrt(2))
It gives the error: Error in X[2:d1, ] : incorrect number of dimensions
fminsearch seems to want a vector of length greater than or equal to 2, but no less, however for this example, the vector requires length 1
Note: fminsearch is in the "pracma" package
It looks like a bug in the pracma package.
The anms function is dropping a dimension upon a subscript, relevant excerpts:
d <- length(x0) # i.e. 1
d1 <- d + 1 # i.e. 2
...
X <- matrix(0, nrow = d1, ncol = d)
...
X <- X[o, ] # could put drop = FALSE here
I think you should post a bug with the author of the package.

How to skip an error in a loop

I want to skip an error (if there is any) in a loop and continue the next iteration. I want to compute 100 inverse matrices of a 2 by 2 matrix with elements randomly sampled from {0, 1, 2}. It is possible to have a singular matrix (for example,
1 0
2 0
Here is my code
set.seed(1)
count <- 1
inverses <- vector(mode = "list", 100)
repeat {
x <- matrix(sample(0:2, 4, replace = T), 2, 2)
inverses[[count]] <- solve(x)
count <- count + 1
if (count > 100) break
}
At the third iteration, the matrix is singular and the code stops running with an error message. In practice, I would like to bypass this error and continue to the next loop. I know I need to use a try or tryCatch function but I don't know how to use them. Similar questions have been asked here, but they are all really complicated and the answers are far beyond my understanding. If someone can give me a complete code specifically for this question, I really appreciate it.
This would put NULLs into inverses for the singular matrices:
inverses[[count]] <- tryCatch(solve(x), error=function(e) NULL)
If the first expression in a call to tryCatch raises an error, it executes and returns the value of the function supplied to its error argument. The function supplied to the error arg has to take the error itself as an argument (here I call it e), but you don't have to do anything with it.
You could then drop the NULL entries with inverses[! is.null(inverses)].
Alternatively, you could use the lower level try. The choice is really a matter of taste.
count <- 0
repeat {
if (count == 100) break
count <- count + 1
x <- matrix(sample(0:2, 4, replace = T), 2, 2)
x.inv <- try(solve(x), silent=TRUE)
if ('try-error' %in% class(x.inv)) next
else inverses[[count]] <- x.inv
}
If your expression generates an error, try returns an object with class try-error. It will print the message to screen if silent=FALSE. In this case, if x.inv has class try-error, we call next to stop the execution of the current iteration and move to the next one, otherwise we add x.inv to inverses.
Edit:
You could avoid using the repeat loop with replicate and lapply.
matrices <- replicate(100, matrix(sample(0:2, 4, replace=T), 2, 2), simplify=FALSE)
inverses <- lapply(matrices, function(mat) if (det(mat) != 0) solve(mat))
It's interesting to note that the second argument to replicate is treated as an expression, meaning it gets executed afresh for each replicate. This means you can use replicate to make a list of any number of random objects that are generated from the same expression.
Instead of using tryCatch you could simply calculate the determinant of the matrix with the function det. A matrix is singular if and only if the determinant is zero.
Hence, you could test whether the determinant is different from zero and calculate the inverse only if the test is positive:
set.seed(1)
count <- 1
inverses <- vector(mode = "list", 100)
repeat {
x <- matrix(sample(0:2, 4, replace = T), 2, 2)
# if (det(x)) inverses[[count]] <- solve(x)
# a more robust replacement for the above line (see comment):
if (is.finite(determinant(x)$modulus)) inverses[[count]] <- solve(x)
count <- count + 1
if (count > 100) break
}
Update:
It is, however, possible to avoid generating singular matrices. The determinant of a 2-by-2 matrix mat is definded as mat[1] * mat[4] - mat[3] * mat[2]. You could use this knowledge for sampling random numbers. Just do not sample numbers which will produce a singular matrix. This, of course, depends on the numbers sampled before.
set.seed(1)
count <- 1
inverses <- vector(mode = "list", 100)
set <- 0:2 # the set of numbers to sample from
repeat {
# sample the first value
x <- sample(set, 1)
# if the first value is zero, the second and third one are not allowed to be zero.
new_set <- ifelse(x == 0, setdiff(set, 0), set)
# sample the second and third value
x <- c(x, sample(new_set, 2, replace = T))
# calculate which 4th number would result in a singular matrix
not_allowed <- abs(-x[3] * x[2] / x[1])
# remove this number from the set
new_set <- setdiff(0:2, not_allowed)
# sample the fourth value and build the matrix
x <- matrix(c(x, sample(new_set, 1)), 2, 2)
inverses[[count]] <- solve(x)
count <- count + 1
if (count > 100) break
}
This procedure is a guarantee that all generated matrices will have an inverse.
try is just a way of telling R: "If you commit an error inside the following parentheses, then skip it and move on."
So if you're worried that x <- matrix(sample(0:2, 4, replace = T), 2, 2) might give you an error, then all you have to do is:
try(x <- matrix(sample(0:2, 4, replace = T), 2, 2))
However, keep in mind then that x will be undefined if you do this and it ends up not being able to compute the answer. That could cause a problem when you get to solve(x) - so you can either define x before try or just "try" the whole thing:
try(
{
x <- matrix(sample(0:2, 4, replace = T), 2, 2)
inverses[[count]] <- solve(x)
}
)
The documentation for try explains your problem pretty well. I suggest you go through it completely.
Edit: The documentation example looked pretty straightforward and very similar to the op's question. Thanks for the suggestion though. Here goes the answer following the example in the documentation page:
# `idx` is used as a dummy variable here just to illustrate that
# all 100 entries are indeed calculated. You can remove it.
set.seed(1)
mat_inv <- function(idx) {
print(idx)
x <- matrix(sample(0:2, 4, replace = T), nrow = 2)
solve(x)
}
inverses <- lapply(1:100, function(idx) try(mat_inv(idx), TRUE))

R - Repetitions of an array in other array

From a dataframe I get a new array, sliced from a dataframe.
I want to get the amount of times a certain repetition appears on it.
For example
main <- c(A,B,C,A,B,V,A,B,C,D,E)
p <- c(A,B,C)
q <- c(A,B)
someFunction(main,p)
2
someFunction(main,q)
3
I've been messing around with rle but it counts every subrepetion also, undersirable.
Is there a quick solution I'm missing?
You can use one of the regular expression tools in R since this is really a pattern matching exercise, specifically gregexpr for this question. The p and q vectors represent the search pattern and main is where we want to search for those patterns. From the help page for gregexpr:
gregexpr returns a list of the same length as text each element of which is of
the same form as the return value for regexpr, except that the starting positions
of every (disjoint) match are given.
So we can take the length of the first list returned by gregexpr which gives the starting positions of the matches. We'll first collapse the vectors and then do the searching:
someFunction <- function(haystack, needle) {
haystack <- paste(haystack, collapse = "")
needle <- paste(needle, collapse = "")
out <- gregexpr(needle, haystack)
out.length <- length(out[[1]])
return(out.length)
}
> someFunction(main, p)
[1] 2
> someFunction(main, q)
[1] 3
Note - you also need to throw "" around your vector main, p, and q vectors unless you have variables A, B, C, et al defined.
main <- c("A","B","C","A","B","V","A","B","C","D","E")
p <- c("A","B","C")
q <- c("A","B")
I'm not sure if this is the best way, but you can simply do that work by:
f <- function(a,b)
if (length(a) > length(b)) 0
else all(head(b, length(a)) == a) + Recall(a, tail(b, -1))
Someone may or may not find a built-in function.
Using sapply:
find_x_in_y <- function(x, y){
sum(sapply(
seq_len(length(y)-length(x)),
function(i)as.numeric(all(y[i:(i+length(x)-1)]==x))
))
}
find_x_in_y(c("A", "B", "C"), main)
[1] 2
find_x_in_y(c("A", "B"), main)
[1] 3
Here's a way to do it using embed(v,n), which returns a matrix of all n-length sub-sequences of vector v:
find_x_in_y <- function(x, y)
sum( apply( embed( y, length(x)), 1,
identical, rev(x)))
> find_x_in_y(p, main)
[1] 2
> find_x_in_y(q, main)
[1] 3

Resources