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.
Related
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
I'm currently doing Advanced-R, 18 Expressions.
Topic is about 18.5.2 Finding all variables created by assignment, but the given code doesn't work in the case of pairlist.
I followed all the given codes, but the results are not quite same with what I expect.
To begin with, in order to figure out what the type of the input, expr_type() is needed.
expr_type <- function(x) {
if(rlang::is_syntactic_literal(x)) {
"constant"
} else if (is.symbol(x)) {
"symbol"
} else if (is.call(x)) {
"call"
} else if (is.pairlist(x)) {
"pairlist"
} else {
typeof(x)
}
}
And the author, hadley, coupled this with a wrapper around the switch function.
switch_expr <- function(x, ...) {
switch(expr_type(x),
...,
stop("Don't know how to handle type ", typeof(x), call. = FALSE)
)
}
In the case of base cases, symbol and constant, is trivial because neither represents assignment.
find_assign_rec <- function(x) {
switch_expr(x,
constant = ,
symbol = character()
)
}
In the case of recursive cases, especially for pairlists, he suggested
flat_map_chr <- function(.x, .f, ...) {
purrr::flatten_chr(purrr::map(.x, .f, ...))
}
So summing up, it follows
find_assign_rec <- function(x) {
switch_expr(x,
# Base cases
constant = ,
symbol = character(),
# Recursive cases
pairlist = flat_map_chr(as.list(x), find_assign_rec),
)
}
find_assign <- function(x) find_assign_rec(enexpr(x))
Then, I expect in the case of pl <- pairlist(x = 1, y = 2), find_assign(pl) should return #> [1] "x" "y"
But the actual output is character(0)
What is wrong with this?
I have been trying to write a code capable of using different classification functions. However, the arguments are different depending on the classification function I use. I would like to have something like this :
classification_flow <- function(classification_function, ...) {
if (classification_function == randomForest) {
...
}
else if (classification_function == svm) {
...
}
}
Of course, this doesn't work since == wasn't built for functions. I've tried using str, names, attr, and looked a bit at methodsand UseMethod, but I can't find a suitable way to do so.
Can anybody help me?
Thanks,
Jess
PS : In this particular case, what I'm trying to do is to get a matrix of probabilities as the output, so something like that :
classification_flow <- function(classification_function, train, classes, ...) {
if (classification_function == randomForest) {
mat = classification_function(train, classes, type="prob")
}
else if (classification_function == svm) {
mat = classification_function(train, classes, probabilities = T)
}
return(mat)
}
If you know a more elegant solution...
You are looking for substitute:
f <- function(x, FUN) {
if (substitute(FUN) == 'max') {
print('Max invoked')
}
FUN(x)
}
> f(1:4, sum)
[1] 10
> f(1:4, max)
[1] "Max invoked"
[1] 4
Here's a version that can get a character or a function. Then you can do character comparisons to find the right case.
classification_flow <- function(classification_function, train, classes, ...) {
if (is.function(classification_function)) {
fname <- deparse(substitute(classification_function))
} else if (is.character(classification_function)) {
fname <- classification_function
classification_function < - get(classification_function)
} else {
stop("invalid classification_function")
}
if (fname == "randomForest") {
mat = classification_function(train, classes, type="prob")
}
else if (fname == "svm") {
mat = classification_function(train, classes, probabilities = T)
}
return(mat)
}
First, make the input to classification_function a character input.
Then, use the switch function to chose between your two options like so:
classification_flow <- function(classification_function, train, classes, ...) {
switch(classification_function,
randomForrest= {mat<-classification_function(train, classes, type="prob")},
svm = { mat<-classification_function(train, classes, probabilities = T) },
stop("You did not pick randomForrest or svm")
)
return(mat)
}
Edit: Added the stop line that gives an error message if neither choice is selected. After you designate all of the options (e.g. svm=) you can add a final line to be executed if there are no prior matches.
You may be able to use the formals function to determine which arguments the function is expecting, then call it accordingly. Also see do.call for a way to dynamically create a function call and call it.
What type of object is passed to myFunc as x? It doesn't seem to be an expression, nor a function and str just evaluates it. I understand that I can use force() to evaluate. I'm wondering if there's some way to gather more information about x without evaluating it.
myFunc = function( x )
{
is.expression( x )
is.function( x )
str( x )
}
myFunc( { x = 5; print( x + 1 ) } )
You can use match.call for extracting the arguments:
myFunc <- function( x ) {
x <- match.call()$x
print(class(x))
print(typeof(x))
print(mode(x))
print(storage.mode(x))
print(is.expression(x))
print(is.call(x))
if (is.call(x)) print(x[[1]])
}
myFunc({x = 5; print("a")})
myFunc(expression(x))
x <- factor(1)
myFunc(x)
myFunc(1)
Probably I need to say that { is a function in R, so {...} is no more than call.
Updated: why x is not function while { is function:
f <- function(x) {
x <- match.call()$x
print(eval(x[[1]]))
print(is.function(eval(x[[1]])))
}
f({1})
I think class would do the trick... See docs.
EDIT: According to the docs,
for {, the result of the last expression evaluated
Which means the class is the class resulting from the evaluation, which is why it not showing up as an "expression". It is being passed after evaluation.
Dason just posted a similar response to this on Talkstats.com for determining if an object is a data frame or a list (click here for a link to that post). I just extended it to an expression which I think suits your needs.
j.list <- function(list, by = NULL){
print("list")
print(list)
}
j.data.frame <- function(df, ..., by = NULL){
print("data frame")
print(df)
}
j.expression <- function(expression, by = NULL){
print("expression")
print(expression)
}
j <- function(x, ...){
UseMethod("j")
}
j(list(test = "this is a list"))
j(data.frame(test = 1:10))
j(expression(1+ 0:9))
I have a function like this dummy-one:
FUN <- function(x, parameter){
if (parameter == 1){
z <- DO SOMETHING WITH "x"}
if (parameter ==2){
z <- DO OTHER STUFF WITH "x"}
return(z)
}
Now, I would like to use the function on a dataset using apply.
The problem is, that apply(data,1,FUN(parameter=1))
wont work, as FUN doesn't know what "x" is.
Is there a way to tell apply to call FUN with "x" as the current row/col?
`
You want apply(data,1,FUN,parameter=1). Note the ... in the function definition:
> args(apply)
function (X, MARGIN, FUN, ...)
NULL
and the corresponding entry in the documentation:
...: optional arguments to ‘FUN’.
You can make an anonymous function within the call to apply so that FUN will know what "x" is:
apply(data, 1, function(x) FUN(x, parameter = 1))
See ?apply for examples at the bottom that use this method.
Here's a practical example of passing arguments using the ... object and *apply. It's slick, and this seemed like an easy example to explain the use. An important point to remember is when you define an argument as ... all calls to that function must have named arguments. (so R understands what you're trying to put where). For example, I could have called times <- fperform(longfunction, 10, noise = 5000) but leaving off noise = would have given me an error because it's being passed through ... My personal style is to name all of the arguments if a ... is used just to be safe.
You can see that the argument noise is being defined in the call to fperform(FUN = longfunction, ntimes = 10, noise = 5000) but isn't being used for another 2 levels with the call to diff <- rbind(c(x, runtime(FUN, ...))) and ultimately fun <- FUN(...)
# Made this to take up time
longfunction <- function(noise = 2500, ...) {
lapply(seq(noise), function(x) {
z <- noise * runif(x)
})
}
# Takes a function and clocks the runtime
runtime <- function(FUN, display = TRUE, ...) {
before <- Sys.time()
fun <- FUN(...)
after <- Sys.time()
if (isTRUE(display)) {
print(after-before)
}
else {
after-before
}
}
# Vectorizes runtime() to allow for multiple tests
fperform <- function(FUN, ntimes = 10, ...) {
out <- sapply(seq(ntimes), function(x) {
diff <- rbind(c(x, runtime(FUN, ...)))
})
}
times <- fperform(FUN = longfunction, ntimes = 10, noise = 5000)
avgtime <- mean(times[2,])
print(paste("Average Time difference of ", avgtime, " secs", sep=""))