Errror: $ not suitable to atomic vectors - r

I need to write a computer program which would look for whether two functions have the same minima points for given parameters, so I wanted to write program which would look for this on some example functions, which minima I know. So I wrote a program, but I get an error 'result$hessian':$ operator is invalid for atomic vectors all the time. But for these given examples, the hessian should be positive, defined, and definitelly non atomic. I don't know whether algorithm get stuck at local minimum or something. Here is the code:
find_min <- function(f) {
n_starts <- 10
min_points <- rep(NA, n_starts)
success <- FALSE
for (i in 1:n_starts) {
result <- tryCatch(optim(par = runif(3, min = -100, max = 100), function(x) -f(x), method = "L-BFGS-B", lower = -100, upper = 100, hessian = TRUE),
error = function(e) {
success <- FALSE
})
if (!is.null(result$hessian) && is.matrix(result$hessian) && any(eigen(result$hessian)$values <= 0)) {
min_points[i] <- NA
success <- FALSE
}
if (is.null(result$hessian)) {
min_points[i] <- NA
success <- FALSE
}
if (is.na(result$par) || !is.numeric(result$par)) {
min_points[i] <- NA
success <- FALSE
}
min_points[i] <- result$par
success <- TRUE
}
if (any(!is.na(min_points))) {
return(min_points[which.min(sapply(min_points, f))])
} else {
return(NA)
}
}
# example functions
f1 <- function(x) {
x[1]^2 + x[2]^2 + x[3]^2
}
f2 <- function(x) {
x[1]^4 + x[2]^4 + x[3]^4
}
min1 <- find_min(f1)
min2 <- find_min(f2)
if (is.na(min1[2]) || is.na(min2[2])) {
print(min1[1])
print(min2[1])
} else if (all(min1[2] == min2[2])) {
print("The minimum points are the same.")
} else if (!all(min1[2] == min2[2])) {
print("The minimum points are different.")
I tried to make sure that hessian is not an atomic vector by trying to catch some errors. I tried to use different starting points in order to get function unstuck if it is stuck at local minima. I tried giving it different example equations. I tried checking the order of if's in hessian checking. Tried to check if is.atomic throws out something but it doesn't even want to compile that. Please help because nothing worked...

result$par are the 3 parameters that optim was initialised with each time; yet you were attempting to place those at a single location of numeric vector (min_points); this is invalid.
but it seems to be not what you say what you wish to do any way.
you are not seeking the min_points you are surely seeking the min_values (reached by whatever points)
i.e.
min_points[i] <- result$value
you can then end the function by returning the minimum of min_points directly.
...
min_points[i] <- result$value
success <- TRUE
}
min(min_points)
}
of course you would probably want to go back and rename min_points to min_vals or whatever you think is descriptive.
making these recommended changes and given your examples results in the following
> min1
[1] -30000
> min2
[1] -3e+08

Related

Error code Missing value where TRUE/FALSE needed in R

I keep getting this error message when I run my code, and I'm not sure what I need to do to fix it.
My code is as follows:
gwmh<-function(target,N,x,sigmasq){
p<-add.var()
samples<-c(x,p)
for(i in 2:N){
prop<-rnorm(1,0,sqrt(sigmasq))
if(runif(1)<min(1,(target(x+abs(prop)*p))/target(x))){
x<-x+prop
samples<-rbind(samples,c(x,p))} else{
p<--p
samples<-rbind(samples,c(x,p))
}
}
samples[(1:N)] ##delete after testing
}
The error says:
Error in if (runif(1) < min(1, (target(x + abs(prop) * p))/target(x))) { :
missing value where TRUE/FALSE needed
(add.var is a function i created to generate p in {-1,1} randomly)
I tested my comment and feel more comfortable offering it as an answer.
Try the following
if(TRUE){print("Test")}
# prints "Test"
if(FALSE){print("Test")}
# prints nothing
if(NA){print("Test")}
# throws your error
So within this expression:
runif(1)<min(1,(target(x+abs(prop)*p))/target(x))
the result is neither TRUE or FALSE but NAand seeing as runif()should not throw any missings it has to be in the rhs of the comparison.
Assuming that target, x, and sigmasq are all values from a df and not functions there is probably a missing value there. If this is the case and also intended you have to add an exception for catching and handling these missings that might look like this:
# test being your test expression
if(
if(is.na(test) {Do Stuff for missing values}
else {original IF statement}
You need to add na.rm=TRUE to the min function to account for possible NA in x.
Your function will fail if x contains NA.
target <- function(x) dnorm(x, 0, 1)
add.var <- function() runif(1, -1, 1)
gwmh <- function(target,N,x,sigmasq){
p <- add.var()
samples<-c(x,p)
for(i in 2:N){
prop<-rnorm(1,0,sqrt(sigmasq))
if(runif(1) < min(1, (target(x+abs(prop)*p))/target(x), na.rm=TRUE)){ # <- Here
x<-x+prop
samples<-rbind(samples,c(x,p))} else{
p<--p
samples<-rbind(samples,c(x,p))
}
}
samples[(1:N)] ##delete after testing
}
Now try:
gwmh(target, N=2, x=c(1,2,NA,3), sigmasq=2)
# [1] 1.00 3.14

Function of function always returns 0-R

I am having a problem writing a function of a function in r. Specifically, I want to calculate the odds of a dice roll in Yahtzee, and when I use explicit parameters, I get a numeric value:
large_straight <- function(){
rolls <- sample(6, size = 5, replace = TRUE)
if(all(Numbers %in% c(rolls))) {
1
} else if (all(Numbers2 %in% c(rolls))) {
1
} else 0
}
sum(replicate(1000, large_straight()))/1000
returns a non-zero value,
but when I try to generalize, so that I can pass not just large straights but also other dice rolls:
my_roll_odds <- function(Size, FUN){
sum(replicate(Size, FUN))/Size
}
my_roll_odds(1000, large_straight())
I always get a return value of 0, and I have zero idea why. Any help would be greatly appreciated!
I think the function could not be evaluated correctly because of the nested calls. Here is a way with match.fun
my_roll_odds <- function(Size, FUN){
sum(replicate(Size, match.fun(FUN)()))/Size
}
my_roll_odds(1000, large_straight)
#[1] 0.029
my_roll_odds(1000, large_straight)
#[1] 0.037

Can I override `$` or `[[` to throw an error instead of NULL when asking for a missing list element?

My hunch is this is an abuse of the R language and there's a good reason this doesn't happen. But I find this to be a perpetual source of insidious errors in code that I'm trying to debug:
MWE
list.1 <- list(a=1,b=2,c=list(d=3))
list.2 <- list(b=4,c=list(d=6,e=7))
input.values <- list(list.1,list.2)
do.something.to.a.list <- function(a.list) {
a.list$b <- a.list$c$d + a.list$a
a.list
}
experiment.results <- lapply(input.values,do.something.to.a.list)
use.results.in.some.other.mission.critical.way <- function(result) {
result <- result^2
patient.would.survive.operation <- mean(c(-5,result)) >= -5
if(patient.would.survive.operation) {
print("Congrats, the patient would survive! Good job developing a safe procedure.")
} else {
print("Sorry, the patient won't make it.")
}
}
lapply(experiment.results, function(x)
use.results.in.some.other.mission.critical.way(x$b))
YES I am aware this is a stupid example and that I could just add a check for the existence of the element before trying to access it. But I'm not asking to know what I could do, if I had perfect memory and awareness at all times, to work slowly around the fact that this feature is inconvenient and causes me lots of headache. I'm trying to avoid the headache altogether, perhaps at the cost of code speed.
So: what I want to know is...
(a) Is it possible to do this. My initial attempt failed, and I got stuck trying to read the C internals for "$" to understand how to handle the arguments correctly
(b) If so, is there a good reason not to (or to) do this.
Basically, my idea is that instead of writing every single function that depends on non-null return from list access to check really carefully, I can write just one function to check carefully and trust that the rest of the functions won't get called with unmet preconditions b/c the failed list access will fail-fast.
You can override almost anything in R (except certain special values - NULL, NA, NA_integer_ NA_real_ NA_complex_, NA_character_, NaN, Inf, TRUE, FALSE as far as I'm aware).
For your specific case, you could do this:
`$` <- function(x, i) {
if (is.list(x)) {
i_ <- deparse(substitute(i))
x_ <- deparse(substitute(x))
if (i_ %in% names(x)) {
eval(substitute(base::`$`(x, i)), envir = parent.frame())
} else {
stop(sprintf("\"%s\" not found in `%s`", i_, x_))
}
} else {
eval(substitute(base::`$`(x, i)), envir = parent.frame())
}
}
`[[` <- function(x, i) {
if (is.list(x) && is.character(i)) {
x_ <- deparse(substitute(x))
if (i %in% names(x)) {
base::`[[`(x, i)
} else {
stop(sprintf("\"%s\" not found in `%s`", i, x_))
}
} else {
base::`[[`(x, i)
}
}
Example:
x <- list(a = 1, b = 2)
x$a
#[1] 1
x$c
#Error in x$c : "c" not found in `x`
col1 <- "b"
col2 <- "d"
x[[col1]]
#[1] 2
x[[col2]]
#Error in x[[col2]] : "d" not found in `x`
It will slow your code down quite a bit:
microbenchmark::microbenchmark(x$a, base::`$`(x, a), times = 1e4)
#Unit: microseconds
# expr min lq mean median uq max neval
# x$a 77.152 81.398 90.25542 82.814 85.2915 7161.956 10000
# base::`$`(x, a) 9.910 11.326 12.89522 12.033 12.3880 4042.646 10000
I've limited this to lists (which will include data.frames) and have implemented selection with [[ by numeric and character vectors, but this may not fully represent the ways in which $ and [[ can be used.
Note for [[ you could use #rawr's simpler code:
`[[` <- function(x, i) if (is.null(res <- base::`[[`(x, i))) simpleError('NULL') else res
but this will throw an error for a member of a list which is NULL rather than just not defined. e.g.
x <- list(a = NULL, b = 2)
x[["a"]]
This may of course be what is desired.

Is it possible to see source code of a value of function

I am using a function from a package. this function returns some values. For example:
k<-dtw(v1,v2, keep.internals=TRUE)
and I can get this value:
k$costMatrix
Does it possible to see the source code of costMatrix? if yes how can I do that?
UPDATE
this is the source code of the function:
function (x, y = NULL, dist.method = "Euclidean", step.pattern = symmetric2,
window.type = "none", keep.internals = FALSE, distance.only = FALSE,
open.end = FALSE, open.begin = FALSE, ...)
{
lm <- NULL
if (is.null(y)) {
if (!is.matrix(x))
stop("Single argument requires a global cost matrix")
lm <- x
}
else if (is.character(dist.method)) {
x <- as.matrix(x)
y <- as.matrix(y)
lm <- proxy::dist(x, y, method = dist.method)
}
else if (is.function(dist.method)) {
stop("Unimplemented")
}
else {
stop("dist.method should be a character method supported by proxy::dist()")
}
wfun <- .canonicalizeWindowFunction(window.type)
dir <- step.pattern
norm <- attr(dir, "norm")
if (!is.null(list(...)$partial)) {
warning("Argument `partial' is obsolete. Use `open.end' instead")
open.end <- TRUE
}
n <- nrow(lm)
m <- ncol(lm)
if (open.begin) {
if (is.na(norm) || norm != "N") {
stop("Open-begin requires step patterns with 'N' normalization (e.g. asymmetric, or R-J types (c)). See papers in citation().")
}
lm <- rbind(0, lm)
np <- n + 1
precm <- matrix(NA, nrow = np, ncol = m)
precm[1, ] <- 0
}
else {
precm <- NULL
np <- n
}
gcm <- globalCostMatrix(lm, step.matrix = dir, window.function = wfun,
seed = precm, ...)
gcm$N <- n
gcm$M <- m
gcm$call <- match.call()
gcm$openEnd <- open.end
gcm$openBegin <- open.begin
gcm$windowFunction <- wfun
lastcol <- gcm$costMatrix[np, ]
if (is.na(norm)) {
}
else if (norm == "N+M") {
lastcol <- lastcol/(n + (1:m))
}
else if (norm == "N") {
lastcol <- lastcol/n
}
else if (norm == "M") {
lastcol <- lastcol/(1:m)
}
gcm$jmin <- m
if (open.end) {
if (is.na(norm)) {
stop("Open-end alignments require normalizable step patterns")
}
gcm$jmin <- which.min(lastcol)
}
gcm$distance <- gcm$costMatrix[np, gcm$jmin]
if (is.na(gcm$distance)) {
stop("No warping path exists that is allowed by costraints")
}
if (!is.na(norm)) {
gcm$normalizedDistance <- lastcol[gcm$jmin]
}
else {
gcm$normalizedDistance <- NA
}
if (!distance.only) {
mapping <- backtrack(gcm)
gcm <- c(gcm, mapping)
}
if (open.begin) {
gcm$index1 <- gcm$index1[-1] - 1
gcm$index2 <- gcm$index2[-1]
lm <- lm[-1, ]
gcm$costMatrix <- gcm$costMatrix[-1, ]
gcm$directionMatrix <- gcm$directionMatrix[-1, ]
}
if (!keep.internals) {
gcm$costMatrix <- NULL
gcm$directionMatrix <- NULL
}
else {
gcm$localCostMatrix <- lm
if (!is.null(y)) {
gcm$query <- x
gcm$reference <- y
}
}
class(gcm) <- "dtw"
return(gcm)
}
but if I write globalCostMatrix I dont get the source code of this function
The easiest way to find how functions work is by looking at the source. You have a good chance that by typing function name in the R console, you will get the function definitions (although not always with good layout, so seeking the source where brackets are present, is a viable option).
In your case, you have a function dtw from the same name package. This function uses a function called globalCostMatrix. If you type that name into R, you will get an error that object was not found. This happens because the function was not exported when the package was created, probably because the author thinks this is not something a regular user would use (but not see!) or to prevent clashes with other packages who may use the same function name.
However, for an interested reader, there are at least two ways to access the code in this function. One is by going to CRAN, downloading the source tarballs and finding the function in the R folder of the tar ball. The other one, easier, is by using getAnywhere function. This will give you the definition of the function just like you're used for other, user accessible functions like dtw.
> library(dtw)
> getAnywhere("globalCostMatrix")
A single object matching ‘globalCostMatrix’ was found
It was found in the following places
namespace:dtw
with value
function (lm, step.matrix = symmetric1, window.function = noWindow,
native = TRUE, seed = NULL, ...)
{
if (!is.stepPattern(step.matrix))
stop("step.matrix is no stepMatrix object")
n <- nrow(lm)
... omitted for brevity
I think you want to see what the function dtw() does with your data. I seems that it creates a data.frame containing a column named costMatrix.
To find out how the data in the column costMatrix was generated, just type and execute dtw (without brackets!). R will show you the source of the function dtw() afterwards.

selection of nlm starting values problem

Need to estimate two parameters using the nlm function;
fit<-nlm(hood2par,c(x01[i],x02[j]),iterlim=300, catch=x[,c(3,4,5)],sp=.5)
where hood2par is a modified logistic
The convergence of nlm depends on the starting values ​​of these parameters. To find such initial values I ​​automatically generate two vectors of starting values
x01 = seq(-10,-20,-0.1)
x02 = seq(0.1,0.9,0.01)
next I create a routine included in a double for() to find the values ​​that lead to the convergence of the function:
for (i in 1:length(x01)) { for (j in 1:length(x02)) {
fit <- NULL
try(fit <- nlm(hood2par, c(x01[i],x02[j]), iterlim = 300, catch = x[,c(3,4,5)],
sp = .5),
silent = TRUE)
stopifnot(is.null(fit))}}
The problem I have is that when I include the previous routine in a function:
FFF <- function(x01, x02, catch){
for (i in 1:length(x01)) {
for (j in 1:length(x02)) {
fit <- NULL
try(fit <- nlm(hood2par, c(x01[i], x02[j]), iterlim = 300,
catch = x[,c(3,4,5)], sp = .5),
silent = TRUE) # does not stop in the case of err
stopifnot(is.null(fit))
}
}
return(fit)
}
I can´t get the 'fit' values from FFF():
> fit.fff<-FFF(x01,x02,catch)
#Error: is.null(fit) is not TRUE
>fit.fff
fit.fff
Error: object 'fit.fff' not found
I used stopifnot(is.null(fit)) to stop the loops when fit is not NULL (as fit is defined as a NULL object before try(...)). Regarding the try code you have shared, I just need this;
res <- try(some_expression)
if(inherits(res, "try-error"))
{
#some code to keep loops running
} else
{
#stop the loops and gather "res"
}
I tried to include the break function in the second argument of the condictional, but it doesn´t run in my R version...Any idea??
When you call FFF, inside the try block if nlm successfully completes, then fit is assigned, and the stopifnot condition is activated, throwing an error.
Wildly guessing, did you mean
stopifnot(!is.null(fit))
For future reference, a standard chunk of code for use with try is
res <- try(some_expression)
if(inherits(res, "try-error"))
{
#some error handling code
} else
{
#normal execution
}

Resources