paste doesn't recognize object - r

I'm trying to run this function, but when I try to compile it, it says:
Error in paste("http://uk.advfn.com/p.php?pid=financials&symbol=", Symbol, :
object 'Symbol' not found
fund.data <- function
(
Symbol, # ticker
n=10, # number of periods
mode=c('quarterly','annual'), # periodicity
max.attempts=5 # maximum number of attempts to download before exiting
)
dirname(sys.frame(1)$ofile)
{
all.data = c()
option.value = -1
start_date = c('istart_date,start_date')
names(start_date) = c('quarterly,annual')
repeat {
# download Quarterly Financial Report data
if(option.value >= 0) {
url = paste('http://uk.advfn.com/p.php?pid=financials&symbol=', Symbol, '&btn=', mode[1], '_reports&', start_date[mode[1]], '=', option.value, sep = '')
} else {
url = paste('http://uk.advfn.com/p.php?pid=financials&symbol=', Symbol, '&btn=', mode[1], '_reports', sep = '')
}
cat('Downloading', url, '\n')
#txt = join(readLines(url))
for(iattempt in 1:max.attempts) {
flag = T
tryCatch({
txt = join(readLines(url))
}, interrupt = function(ex) {
flag <<- F
Sys.sleep(0.1)
}, error = function(ex) {
flag <<- F
Sys.sleep(0.1)
}, finally = {
if(flag) break
})
}
if( length(grep('INDICATORS', txt, ignore.case = T)) == 0 ) {
cat('No Data Found for', Symbol, '\n')
return(all.data)
}
# get title
pos = regexpr(pattern = '<title>(.*?)</title>', txt, ignore.case = TRUE, perl = TRUE)
if(length(pos) == 1)
title = substr(txt, attr(pos, 'capture.start'), attr(pos, 'capture.start') + attr(pos, 'capture.length') - 1)
# extract table from this page
data = extract.table.from.webpage(txt, 'INDICATORS', has.header = T)
colnames(data) = data[1,]
rownames(data) = data[,1]
data = data[,-1,drop=F]
# only add not already present data
add.index = which( is.na(match( colnames(data), colnames(all.data) )) )
all.data = cbind(data[,add.index,drop=F], all.data)
# check if it is time to stop
if(ncol(all.data) >= n) break
if(option.value == 0) break
# extract option value to go to the next page
temp = gsub(pattern = '<option', replacement = '<tr>', txt, perl = TRUE)
temp = gsub(pattern = '</option>', replacement = '</tr>', temp, perl = TRUE)
temp = extract.table.from.webpage(temp, 'All amounts', has.header = T)
temp = apply(temp,1,join)
index.selected = grep('selected', temp)
option.value = 0
if( length(index.selected) )
option.value = as.double( gsub('.*value=\'([0-9]*).*', '\\1', temp[index.selected]) )
if(option.value > 0) {
# can only get 5 time periods at a time
option.value = option.value - 5
option.value = max(0, option.value)
} else {
break
}
}
# remove empty columns
all.data = all.data[, colSums(nchar(trim(all.data))) > 0, drop=F]
all.data = rbind(all.data, title)
rownames(all.data)[nrow(all.data)] = 'HTMLTITLEtext'
if( ncol(all.data) > n ) {
return(all.data[,(ncol(all.data)-n+1):ncol(all.data), drop=F])
} else {
return(all.data)
}
}

The way you've written your code, your dirname() call comprises the entirety of the body of your function. The braced block that follows is executed immediately and is not part of the function.
After running all your code (and getting the error you quoted), this is fund.data():
fund.data;
## function
## (
## Symbol, # ticker
## n=10, # number of periods
## mode=c('quarterly','annual'), # periodicity
## max.attempts=5 # maximum number of attempts to download before exiting
## )
## dirname(sys.frame(1)$ofile)
As you can see, the braced block was not taken as part of the function definition. It was executed by itself immediately after fund.data() was defined. A function definition takes only the immediately following expression as the body, although that expression may comprise a braced block, which allows any number of statements to be subsumed within it. And as #RichardScriven pointed out in his comment, there is no actual call to your function anywhere in your code.
So, the reason why you're getting the exact error "object 'Symbol' not found" is because the function parameter Symbol does not exist in your braced block, because it is not part of the body of your function and was executed by itself.
To solve your problem, you need to surround the entire function body with a braced block:
fund.data <- function
(
Symbol, # ticker
n=10, # number of periods
mode=c('quarterly','annual'), # periodicity
max.attempts=5 # maximum number of attempts to download before exiting
) {
dirname(sys.frame(1)$ofile)
all.data = c()
option.value = -1
...
}
Although it's not clear what the purpose of the dirname() call is, since its return value is not used.

Related

RStudio error - creating large environment object: protect(): protection stack overflow

I want to create a large lookup table of key value pairs, attempting it like this:
# actual use case is length ~5 million
key <- do.call(paste0, Map(stringi::stri_rand_strings, n=2e5, length = 16))
val <- sample.int(750, size = 2e5, replace = T)
make_dict <- function(keys, values){
require(rlang)
e <- new.env(size = length(keys))
l <- list2(!!!setNames(values, keys))
list2env(l, envir = e, hash = T) # problem in here...?
}
d <- make_dict(key, val)
Problem
When make_dict is run it throws Error: protect(): protection stack overflow. Specifically in RStudio when the input is a vector of length is greater than 49991, which seems very similar to this stackoverflow post.
However, when I run accessor functions to grab some of the values, it seems that make_dict ran fine after all, as I can't find any oddities in its result:
`%||%` <- function(x,y) if(is.null(x)) y else x
grab <- function(...){
vector("integer", length(..2)) |>
(\(.){. = Vectorize(\(e, x) e[[x]] %||% NA_integer_, list("x"), T, F)(..1, ..2); .})()
}
out <- vector("integer", length(key))
out <- grab(d, sample(key)) # using sample to scramble the keys
anyNA(out) | !lobstr::obj_size(out) == lobstr::obj_size(val)
[1] FALSE
Running the same code in RGui does not throw the error.
Oddities
The d environment object does not appear in environment pane in RStudio for size > 5e4.
The R console returns swiftly back to > (signaling the function has finished), but is unresponsive until the error is thrown
Error is thrown if manually setting options(expressions = 5e5), or retaining the default value of 5000
When the error is thrown is proportional to the size of the input vector
tryCatch(make_dict(key, val), error = function(e) e) doesn't catch an error
The error also occurs if code is run from package (Packaged version available through remotes::install_github("D-Se/minimal"))
Question
What's going on here? How to troubleshoot such an error?
options(error = traceback) as advised here didn't give any results. Inserting a browser() after list2env in the make_dict function throws an error long after the browser has opened. A traceback() gives the function .rs.describeObject, which is used to generate the summary in the Environment pane, and can be found here.
traceback()
# .rs.describeObject
(function (env, objName, computeSize = TRUE)
{
obj <- get(objName, env)
hasNullPtr <- .Call("rs_hasExternalPointer", obj, TRUE, PACKAGE = "(embedding)")
if (hasNullPtr) {
val <- "<Object with null pointer>"
desc <- "An R object containing a null external pointer"
size <- 0
len <- 0
}
else {
val <- "(unknown)"
desc <- ""
size <- if (computeSize)
object.size(obj)
else 0
len <- length(obj)
}
class <- .rs.getSingleClass(obj)
contents <- list()
contents_deferred <- FALSE
if (is.language(obj) || is.symbol(obj)) {
val <- deparse(obj)
}
else if (!hasNullPtr) {
if (size > 524288) {
len_desc <- if (len > 1)
paste(len, " elements, ", sep = "")
else ""
if (is.data.frame(obj)) {
val <- "NO_VALUE"
desc <- .rs.valueDescription(obj)
}
else {
val <- paste("Large ", class, " (", len_desc,
format(size, units = "auto", standard = "SI"),
")", sep = "")
}
contents_deferred <- TRUE
}
else {
val <- .rs.valueAsString(obj)
desc <- .rs.valueDescription(obj)
if (class == "data.table" || class == "ore.frame" ||
class == "cast_df" || class == "xts" || class ==
"DataFrame" || is.list(obj) || is.data.frame(obj) ||
isS4(obj)) {
if (computeSize) {
contents <- .rs.valueContents(obj)
}
else {
val <- "NO_VALUE"
contents_deferred <- TRUE
}
}
}
}
list(name = .rs.scalar(objName), type = .rs.scalar(class),
clazz = c(class(obj), typeof(obj)), is_data = .rs.scalar(is.data.frame(obj)),
value = .rs.scalar(val), description = .rs.scalar(desc),
size = .rs.scalar(size), length = .rs.scalar(len), contents = contents,
contents_deferred = .rs.scalar(contents_deferred))
})(<environment>, "d", TRUE)
This github issue pointed out by #technocrat talks about a known bug in earlier versions of RStudio of disabling null external pointer checks, and has since been solved by adding an additional preference check in .rs.describeObject() of
.rs.readUiPref("check_null_external_pointers")
To check if code is run from within RStudio, and if that version is lower than that of before a certain version number (here I use the current official release), a check can be included in the function, or in the .OnAttach of a package:
if(!is.na(Sys.getenv("RSTUDIO", unset = NA)) && .rs.api.versionInfo()$version < "2021.9.1.372")){
# warning or action
}

Killing ghost NULL console outputs?

edit: added full code
I made an S4 method for 'plot' that appears to be working, except it outputs some stray NULL to the console and I can't figure out where it's coming from. Here's the top level code:
print(plot(x = flux, y = 1, fastplot = TRUE, quietly = TRUE))
And the class:
flux <- setClass(
# Set the class name
"flux",
slots = c(
raw.data = "list",
source.files = "character",
data = "matrix",
time = "POSIXct",
datatype = "character",
metadata = "data.frame"
)
)
And the method:
setMethod("plot",
signature(x = "flux"),
function (x, y, ...) {
CheckFluxObject(x)
params <- LoadDefaults(flux = x)
# Interpret 'plot' arguments
par.restore <- par(no.readonly = TRUE)
on.exit(expr = par(par.restore), add = TRUE)
arguments <- list(...)
if (!("fastplot" %in% names(arguments))) {
fastplot <- FALSE
} else {
fastplot <- arguments$fastplot
arguments$fastplot <- NULL
}
if (!("quietly" %in% names(arguments))) {
quietly <- FALSE
} else {
quietly <- arguments$quietly
arguments$quietly <- NULL
}
par(ask=!(fastplot))
if (!("ylab" %in% arguments)) {
ylab <- params["units"]
} else {
ylab <- arguments$ylab
arguments$ylab <- NULL
}
# Pull relevant 'flux' class object data
data <- slot(x, "data")
if (missing("y")) {
y <- 1:ncol(data)
} else {
stopifnot(
is.integer(y),
all(y %in% 1:ncol(data))
)
}
# Bulk function execution
if (quietly == FALSE) {
message("Plotting data traces:")
}
plot.obj <- plot.new()
print("NULL is in the 'for' loop...")
for (i in y){
main <- colnames(data)[i]
plot.obj <- plot(slot(x, "time"), data[, i], main = main,
xlab = "Time", ylab = ylab, unlist(arguments))
print(plot.obj)
}
print("but is it also here??")
# Clean-up and exit
if (quietly == FALSE) {
message("Done plotting.")
}
if (length(y) == 1) {
invisible(plot.obj)
}
print("or here??")
invisible(NULL)
}
)
The output for that is:
[1] "NULL is in the 'for' loop..."
NULL
[1] "but is it also here??"
[1] "or here??"
NULL
If I throw in another print("what about here??") after the invisible(NULL),
then it does this:
[1] "NULL is in the 'for' loop..."
NULL
[1] "but is it also here??"
[1] "or here??"
[1] "what about here??"
[1] "what about here??"
Is there some behavior of the function return or print commands that I'm not anticipating? The CheckFluxObject function just checks to make sure all the slots are filled.
I'll leave this here till a better answer pops up, if ever:
Apparently the print method for plot objects returns a NULL, and if you're trying to generate a plot within a function it seems like the best way to do that is using invisible(plot.object) or invisible(plot(x, y, ...)), NOT print.
I'm still not sure where the 2nd NULL is coming from...
edit: Found the second one! Just like the print(plot.obj) in the method itself, the print in the top-level code was throwing a NULL. Dropping all of the print commands killed all of the ghosts.

Pass an argument in the form of a character vector in order to use it later inside the select argument of the `subset()` function

I'm trying to pass an argument in the form of a character vector (called keep_col) in order to use it later inside the select argument of the subset() function, and all of this is inside a bigger function called early_prep() I created.
Bellow is the relevant part of my code.
early_prep <- function(file_name, results_name, id = NULL ,keep_rows = FALSE, keep_col = FALSE, within_vars = c(), reaction_time = NULL, accuracy = NULL, clear_all = FALSE, decimal_places = 4){
if (clear_all %in% TRUE){
# Removes all objects form the console
rm(list = ls())
}
# Call read_data() function
read_data(file_name)
if (keep_rows != FALSE) {
raw_data <<- subset(raw_data, eval(parse(text = keep_rows)))
# Print to console
print("#### Deleting unnecesarry rows in raw_data ####", quote = FALSE)
}
if (keep_col != FALSE) {
raw_data <<- subset(raw_data, select = keep_col)
# Print to console
print("#### Deleting unnecesarry columns in raw_data ####", quote = FALSE)
}
}
The problem is when I call early_prep(file_name ="n44.txt", keep_col = c("subject", "soa", "congruency")) I get the following warning message:
> early_prep(file_name = "n44.txt", keep_col = c("subject", "soa", "congruency"))
[1] #### Reading txt file ####
[1] #### Deleting unnecesarry columns in raw_data ####
Warning message:
In if (keep_col != FALSE) { :
the condition has length > 1 and only the first element will be used
Does anyone have an idea about how I can solve this problem?
Any help will be greatly appreciated
Best,
Ayala

R .Last.call feature - similar to .Last.value

Similarly to .Last.value is there any way to access last call? Below expected results of potential .Last.call.
sum(1, 2)
# [1] 3
str(.Last.call)
# language sum(1, 2)
The bests if it would not require to parse file from file system.
The last.call package is no longer on cran, but you can still get the code:
# -----------------------------------------------------------------------
# FUNCTION: last.call
# Retrieves a CALL from the history and returns an unevaluated
# call.
#
# There are two uses for such abilities.
# - To be able to recall the previous commands, like pressing the up key
# on the terminal.
# - The ability to get the line that called the function.
#
# TODO:
# - does not handle commands seperated by ';'
#
# -----------------------------------------------------------------------
last.call <-
function(n=1) {
f1 <- tempfile()
try( savehistory(f1), silent=TRUE )
try( rawhist <- readLines(f1), silent=TRUE )
unlink(f1)
if( exists('rawhist') ) {
# LOOK BACK max(n)+ LINES UNTIL YOU HAVE n COMMANDS
cmds <- expression()
n.lines <- max(abs(n))
while( length(cmds) < max(abs(n)) ) {
lines <- tail( rawhist, n=n.lines )
try( cmds <- parse( text=lines ), silent=TRUE )
n.lines <- n.lines + 1
if( n.lines > length(rawhist) ) break
}
ret <- rev(cmds)[n]
if( length(ret) == 1 ) return(ret[[1]]) else return(ret)
}
return(NULL)
}
Now, to use it:
sum(1, 2)
# [1] 3
last.call(2)
# sum(1, 2)
I've modified this code to output text strings of the preceding commands / calls in a manner that preserves how there were formatted across lines in the original call, sot that I can use cat() to output the calls (for a function that emails me when the preceding function is done running). Here's the code:
lastCall <- function(num.call = 1) {
history.file <- tempfile()
try(savehistory(history.file), silent = TRUE )
try(raw.history <- readLines(history.file), silent = TRUE )
unlink(history.file)
if (exists('raw.history') ) {
# LOOK BACK max(n)+ LINES UNTIL YOU HAVE n COMMANDS
commands <- expression()
num.line <- max(abs(num.call) + 1)
while (length(commands) < max(abs(num.call) + 1)) {
lines <- tail(raw.history, n = num.line)
try(commands <- parse(text = lines), silent = TRUE)
num.line <- num.line + 1
if (num.line > length(raw.history)) break
}
ret <- rev(commands)[num.call + 1]
if (length(ret) == 1) {
a <- ret[1]
} else {
a <- ret
}
# a <- rev(commands)[num.call + 1]
out <- lapply(a, deparse) %>%
sapply(paste, sep = "\n", collapse = "\n")
}
out
}
Enjoy!

Grep in R using conditions on the matching

I am using the tm in R and would like to change the stemCompletion function a little.
Currently when I have a string
x <- c('everi','new')
and a pattern
dictionary <- c ('every','everyone','new')
When I run the build in code in the stemCompletion, the function that is running is the following
possibleCompletions <- lapply(x, function(w) grep(sprintf("^%s", w),
dictionary,
value = TRUE))
structure(sapply(possibleCompletions, "[", 1), names = x)
and the result is
everi new
NA "new"
I want to change the function so that if the grep does not find anything for a particular value of x
then it tries by taking out the last value of the string. In my case 'ever' instead of 'everi'
I tried this code but it does not work.
substrLeft <- function(x, n) { substr(x, 1, nchar(x)-n) }
possibleCompletions <- lapply(x, function(w)
if (grepl(sprintf("^%s", w),dictionary,fixed = FALSE) = FALSE) {
grep(sprintf("^%s", substrLeft(w,1)),dictionary,value = TRUE,fixed = FALSE)
} else {
grep(sprintf("^%s", w),dictionary,value = TRUE,fixed = FALSE, invert = TRUE)
})
structure(sapply(possibleCompletions, "[", 1), names = x)
Thanks all.
Basically you have a few syntax problems.
First, = is assignment, == compares.
Also, if conditions in ℝ are, according to the manual "a single logical value". So you could get around this by wrapping a comparison in parentheses ((grepl(sprintf("^%s", w),dictionary,fixed = FALSE) == FALSE)) but you'll get warnings since grepl produces a list of length 2.
Finally, your one-line function has expanded to several lines, so you'll need to wrap it in {}:
possibleCompletions <- lapply(x, function (w) {
+ if ((grepl(sprintf("^%s", w),dictionary,fixed = FALSE) == FALSE) ) {
+ grep(sprintf("^%s", substrLeft(w,1)),dictionary,value = TRUE,fixed = FALSE)
+ } else {
+ grep(sprintf("^%s", w),dictionary,value = TRUE,fixed = FALSE, invert = TRUE)
+ }
+ })
Warning messages:
1: In if ((grepl(sprintf("^%s", w), dictionary, fixed = FALSE) == FALSE)) { :
the condition has length > 1 and only the first element will be used
2: In if ((grepl(sprintf("^%s", w), dictionary, fixed = FALSE) == FALSE)) { :
the condition has length > 1 and only the first element will be used
> str(possibleCompletions)
List of 2
$ : chr [1:2] "every" "everyone"
$ : chr "new"

Resources