Assume I have the following function:
f1 <- function()
{
get.var <- function(v)
{
for(n in 1:sys.nframe())
{
varName <- deparse(substitute(v, env = parent.frame(n)))
if(varName != "v")
{
break
}
}
return(list(name = varName, n = n))
}
f2 <- function(v)
{
print(v)
# get original variable name and environment
obj <- get.var(v)
#below doesn't work as expected - this is where q$a and q$b would be updated
assign(obj$name, v + 1, env = parent.frame(obj$n))
}
f3 <- function(v){ f2(v) }
f4 <- function(v){ f3(v) }
q <- list(a = 2, b = 3)
f4(q$a)
f3(q$b)
}
How can I update the value of q$a and q$b from f2? The situation is that a similar routine is called in some of my code to validate a number of arguments in a nested list. If a value is incorrect the list element needs to be updated to reflect the correct value. It's certainly an ugly way to do it but unfortunately I cannot pass the entire list to each and every validation function.
A somewhat similar question was asked here but the user was passing in a list element instead.
Instead of using assign(obj$name, v + 1, env = parent.frame(obj$n)), I replaced this with eval(parse(text = sprintf("%s <- %d", obj$name, v + 1)), envir = parent.frame(obj$n))
It is horrendously ugly, but it works.
Related
Given the following data:
list_A <- list(data_cars = mtcars,
data_air = AirPassengers,
data_list = list(A = 1,
B = 2))
I would like to print names of objects available across list_A.
Example:
Map(
f = function(x) {
nm <- deparse(match.call()$x)
print(nm)
# nm object is only needed to properly name flat file that may be
# produced within Map call
if (any(class(x) == "list")) {
length(x) + 1
} else {
length(x) + 1e6
saveRDS(object = x,
file = tempfile(pattern = make.names(nm), fileext = ".RDS"))
}
},
list_A
)
returns:
[1] "dots[[1L]][[1L]]"
[1] "dots[[1L]][[2L]]"
[1] "dots[[1L]][[3L]]"
$data_cars
NULL
$data_air
NULL
$data_list
[1] 3
Desired results
I would like to get:
`data_cars`
`data_air`
`data_list`
Update
Following the comments, I have modified the example to make it more reflective of my actual needs which are:
While using Map to iterate over list_A I'm performing some operations on each element of the list
Periodically I want to create a flat file with name reflecting name of object that was processed
In addition to list_A, there are also list_B, list_C and so forth. Therefore, I would like to avoid calling names(list) inside the function f of the Map as I will have to modify it n number of times. The solution I'm looking to find should lend itself for:
Map(function(l){...}, list_A)
So I can later replace list_A. It does not have to rely on Map. Any of the apply functions would do; same applied to purrr-based solutions.
Alternative example
do_stuff <- function(x) {
nm <- deparse(match.call()$x)
print(nm)
# nm object is only needed to properly name flat file that may be
# produced within Map call
if (any(class(x) == "list")) {
length(x) + 1
} else {
length(x) + 1e6
saveRDS(object = x,
file = tempfile(pattern = make.names(nm), fileext = ".RDS"))
}
}
Map(do_stuff, list_A)
As per the notes below, I want to avoid having to modify do_stuff function as I will be looking to do:
Map(do_stuff, list_A)
Map(do_stuff, list_B)
Map(do_stuff, list_...)
We could wrap it into a function, and do it in two steps:
myFun <- function(myList){
# do stuff
res <- Map(
f = function(x) {
#do stuff
head(x)
},
myList)
# write to a file, here we might add control
# if list is empty do not output to a file
for(i in names(res)){
write.table(res[[ i ]], file = paste0(i, ".txt"))
}
}
myFun(list_A)
Would something like this work ?
list_A2 <- Map(list, x = list_A,nm = names(list_A) )
trace(do_stuff, quote({ nm <- x$nm; x<- x$x}), at=3)
Map(do_stuff, list_A2)
I am creating some functions for myself and I don't know how to proceed in order to use an object (e.g. a value) returned from one function to another one, while the console is still running. As an example:
first <- function(x){
return(x)
}
second <- function(y){
z <- x + y
return(z)
}
So if you call these functions with a '+'...
first(x = 5) +
second(y = 5)
I would expect a value of 10. In this particular case, obviously the function second() can't find the object x, because the latter one was assigned in the first() environment.
This style of programming is similar to ggplot(), for example:
ggplot(aes(x = x, y = y), data = data) +
geom_point()
I know this type of programming implies the use of environments, but I can't get it work. Any suggestions?
Thanks!
EDIT
Looking to ggplot package in github I figured it out, I think:
hh_first <- function(data) {
h <- structure(list(data = data), class = c("hh"))
h
}
"+.hh" <- function(e1, e2) {
add_hh(e1, e2)
}
add_hh <- function(h, object) {
h$data <- paste(h$data, object, sep = "")
h$data
}
hh_second <- function(data) {
data
}
For example...
hh_first('Hi') +
hh_second(', how are you?')
Returns a string 'Hi, how are you?'. The plus operator in this case works with objects of class 'hh'.
Any suggestions regarding the code or perhaps possible errors that this kind of coding may produce are welcome.
Try:
first <- function(x){
return(x)
}
second <- function(x ,y){
z <- x + y
return(z)
}
second(first(5), 5)
OR
myX <- first(5)
second(myX, 5)
OR
library(magrittr) # Which uses pipes, %>%, to pass the results of a function to the first variable of the second function
first(5) %>% second(5)
Context
I am using in R, the "elipsis" or "dots" that wrap function calls
main_function <- function(...)
If I want to evaluate once, I do
main_function <- function(...) {
res = list(...)}
It works fine
Problem
fun_A <- function(arg_A){
print(paste("I am A", paste0(round(runif(arg_A, 0,1), 2),collapse = ", ")))
}
fun_B <- function(arg_B){
print(paste("I am B", paste0(round(runif(arg_B, 1,2), 2),collapse = ", ")))
}
Here the result is evaluated once and replicate 3 times :
main_fun_wrong <- function(..., times) {
res = list(...)
replicate(times, eval(res))
}
main_fun_wrong(fun_A(1), fun_B(2), times = 3)
Here it works :
main_fun <- function(..., times) {
calls = match.call(expand.dots = FALSE)$`...`
replicate(times, lapply(1:length(calls), function(num) eval(calls[[num]])), simplify = F)
}
main_fun(fun_A(1),fun_B(2), times = 3)
But now if arg_A is an object rather than a value, it will fail finding the arg_A and arg_B in the environment.
main_fun_problem <- function(arg_A, arg_B) {
main_fun(fun_A(arg_A),fun_B(arg_B), times = 3)
}
main_fun_problem(1,2)
I got an error :
Error in fun_A(arg_A) : object 'arg_A' not found
I do not know what R do when it find list(...) the first time in first example but I just want to repeat it multiple times.
Here is my solution, any alternative will be enjoyed.
The things is to substitute the variable by it's value at the moment we call the function.
main_fun_solution <- function(arg_A, arg_B) {
eval(substitute(main_fun(fun_A(arg_A),fun_B(arg_B), times = 3), list("arg_A" = arg_A, "arg_B" = arg_B)))
}
main_fun_solution(1,2)
NB: list("arg_A" = arg_A, "arg_B" = arg_B)` makes my heart bleed (the overall solution actually)
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.
After some manipulation of data, I want to rename automatically the data taking pieces of name from a string, merging togheter these pieces and then assigning to data. I try to use "if" function in for loop but the code doesn't work. I try to use "grep" as condition in "if" function.
filepath<-c("C:/Users/Amministratore/Documents/Isolante-T_0-W_0-P1_0.csv",
"C:/Users/Amministratore/Documents/Isolante-T_0-W_0-P1_1.csv",
"C:/Users/Amministratore/Documents/Isolante-T_0-W_0-P1_2.csv",
"C:/Users/Amministratore/Documents/Isolante-T_0-W_0-P1_3.csv",
"C:/Users/Amministratore/Documents/Isolante-T_0-W_0-P1_4.csv",
"C:/Users/Amministratore/Documents/Isolante-T_0-W_0-P1_5.csv",
"C:/Users/Amministratore/Documents/Isolante-T_0-W_0-P1_6.csv",
"C:/Users/Amministratore/Documents/Isolante-T_0-W_1-P1_0.csv",
"C:/Users/Amministratore/Documents/Isolante-T_0-W_1-P1_1.csv",
....)
for(i in filepath){
......
f <- substr(i,10,23) # first piece of name
f2 <- as.character(substr(i,40,57)) # second piece of name
if (grep("W_0",f2)){
m<-c("_sin")
}
if (grep("W_1",f2)){
m<-c("_jan2_febreal")
}
if (grep("W_2",f2)){
m<-c("_real")
}
if (grep("W_3",f2)){
m<-c("_step")
}
if (grep("P1_0",f2,value = FALSE)){
t<-c("_t0.025")
}
if (grepl("P1_1",f2,value = FALSE)){
t<-c("_t0.05")
}
if (grepl("P1_2",f2,value = FALSE)){
t<-c("_t0.1")
}
if (grepl("P1_3",f2,value = FALSE)){
t<-c("_t0.15")
}
if (grepl("P1_4",f2,value = FALSE)){
t<-c("_t0.2")
}
if (grepl("P1_5",f2,value = FALSE)){
t<-c("_t0.25")
}
if (grepl("P1_6",f2,value = FALSE)){
t<-c("_t0.3")
}
}
Outputfilename <- paste(paste(f,m,sep=""),t,sep="")
the result is:
Errore in if (grep("W_1", f2)) { : l'argomento ha lunghezza zero
Without any for loops or if statements, it seems to me you can simply vectorize everything:
f <- substr(filepath,10,23)
m <- t <- character(length(filepath))
m[grepl("W_0",filepath)]<-"_sin"
m[grepl("W_1",filepath)]<-"_jan2_febral"
m[grepl("W_2",filepath)]<-"_real"
m[grepl("W_3",filepath)]<-"_step"
t[grepl("P1_0",filepath)]<-"_t0.025"
t[grepl("P1_1",filepath)]<-"_t0.05"
t[grepl("P1_2",filepath)]<-"_t0.1"
t[grepl("P1_3",filepath)]<-"_t0.15"
t[grepl("P1_4",filepath)]<-"_t0.2"
t[grepl("P1_5",filepath)]<-"_t0.25"
t[grepl("P1_6",filepath)]<-"_t0.3"
Outputfilename <- paste(f,m,t,sep="")
That you can also probably simplify the following way:
f <- substr(filepath,10,23)
m <- t <- character(length(filepath))
w <- array(c(paste("W",0:3,sep="_"),
"_sin", "_jan2_febral", "_real", "_step"), dim=c(4,2))
p <- array(c(paste("P1",0:6,sep="_"),
paste("t_0.",c("025","05","1","15","2","25","3"),sep="")), dim=c(7,2))
for(i in 1:nrow(w)){m[grepl(w[i,1],filepath)] <- w[i,2]}
for(i in 1:nrow(p)){t[grepl(p[i,1],filepath)] <- p[i,2]}
Outputfilename <- paste(f,m,t,sep="")
That you can wrap in a function if you like:
outputfile.namer <- function(filepath,w,p){
# filepath being your vector of file paths
# w and p your correspondance tables for your "W_" and "P_" series respectively
f <- do.call(rbind,strsplit(gsub("C:/Users/","",filepath),split="/"))[,1]
# the preceding is more general than `f <- substr(filepath,10,23)` to grab the name of the User
m <- t <- character(length(filepath))
for(i in 1:nrow(w)){m[grepl(w[i,1],filepath)] <- w[i,2]}
for(i in 1:nrow(p)){t[grepl(p[i,1],filepath)] <- p[i,2]}
paste(f,m,t,sep="")
}