How to modify pre-existing function in local environment in R - r

I am trying to modify an existing function by copy and pasting it to an R script, and assigning it to a new function object in my local environment. However the new function cannot find functions that are called to within the original function. How can I fix this without looking up and finding each function individually? I am guessing that the original function is somehow linked to the package or its dependencies and 'knows where to look' for the missing function, but I cannot figure out how to do this with my new copy-and-pasted function.
library("camtrapR")
Print the function name
activityDensity
The output here is the code for this function. I have omitted it here because it is long (and I have pasted it below), but I copy and paste the output of the function code exactly (see below where I assign this exact code to a new function), except for the last two lines of output, which I think are important:
<bytecode: 0x000000002a2d1e20>
<environment: namespace:camtrapR>
So now I assign the copy and pasted code from the output above to a new function with New <-
New <- function (recordTable, species, allSpecies = FALSE, speciesCol = "Species",
recordDateTimeCol = "DateTimeOriginal", recordDateTimeFormat = "%Y-%m-%d %H:%M:%S",
plotR = TRUE, writePNG = FALSE, plotDirectory, createDir = FALSE,
pngMaxPix = 1000, add.rug = TRUE, ...)
{
wd0 <- getwd()
mar0 <- par()$mar
on.exit(setwd(wd0))
on.exit(par(mar = mar0), add = TRUE)
recordTable <- dataFrameTibbleCheck(df = recordTable)
timeZone <- "UTC"
checkForSpacesInColumnNames(speciesCol = speciesCol, recordDateTimeCol = recordDateTimeCol)
if (!is.data.frame(recordTable))
stop("recordTable must be a data frame", call. = FALSE)
if (!speciesCol %in% colnames(recordTable))
stop(paste("speciesCol = \"", speciesCol, "\" is not a column name in recordTable",
sep = ""), call. = FALSE)
if (!recordDateTimeCol %in% colnames(recordTable))
stop(paste("recordDateTimeCol = \"", recordDateTimeCol,
"\" is not a column name in recordTable", sep = ""),
call. = FALSE)
stopifnot(is.logical(c(allSpecies, writePNG, plotR, createDir)))
if (allSpecies == FALSE) {
stopifnot(species %in% recordTable[, speciesCol])
stopifnot(hasArg(species))
}
recordTable$DateTime2 <- parseDateTimeObject(inputColumn = recordTable[,
recordDateTimeCol], dateTimeFormat = recordDateTimeFormat,
timeZone = timeZone)
recordTable$Time2 <- format(recordTable$DateTime2, format = "%H:%M:%S",
usetz = FALSE)
recordTable$Time.rad <- (as.numeric(as.POSIXct(strptime(recordTable$Time2,
format = "%H:%M:%S", tz = timeZone))) - as.numeric(as.POSIXct(strptime("0",
format = "%S", tz = timeZone))))/3600 * (pi/12)
if (isTRUE(writePNG)) {
if (hasArg(plotDirectory)) {
if (isTRUE(createDir)) {
dir.create(plotDirectory, recursive = TRUE, showWarnings = FALSE)
setwd(plotDirectory)
}
else {
stopifnot(file.exists(plotDirectory))
setwd(plotDirectory)
}
}
else {
stop("writePNG is TRUE. Please set plotDirectory",
call. = FALSE)
}
}
pngWidth <- pngMaxPix
pngHeight <- round(pngMaxPix * 0.8)
if (allSpecies == FALSE) {
subset_species <- subset(recordTable, recordTable[, speciesCol] ==
species)
if (nrow(subset_species) == 1)
stop(paste(species, "had only 1 record. Cannot estimate density."),
call. = FALSE)
try_error_tmp <- try({
if (isTRUE(writePNG))
png(filename = paste("activity_density_",
species, "_", Sys.Date(), ".png",
sep = ""), width = pngWidth, height = pngHeight,
units = "px", res = 96, type = "cairo")
if (isTRUE(writePNG) | isTRUE(plotR)) {
densityPlot(subset_species$Time.rad, main = paste("Activity of",
species), rug = add.rug, ...)
mtext(paste("number of records:", nrow(subset_species)),
side = 3, line = 0)
}
if (isTRUE(writePNG))
dev.off()
}, silent = TRUE)
if (class(try_error_tmp) == "try-error")
warning(paste(toupper(species), ": ", try_error_tmp[1],
" - SKIPPED", sep = ""), call. = FALSE)
}
else {
subset_species_list <- list()
for (i in 1:length(unique(recordTable[, speciesCol]))) {
spec.tmp <- unique(recordTable[, speciesCol])[i]
subset_species <- subset(recordTable, recordTable[,
speciesCol] == spec.tmp)
plot_main_title <- paste("Activity of", spec.tmp)
if (nrow(subset_species) == 1) {
warning(paste(toupper(spec.tmp), ": It had only 1 record. Cannot estimate density. - SKIPPED",
sep = ""), call. = FALSE)
next
}
else {
try_error_tmp <- try({
if (isTRUE(writePNG))
png(filename = paste("activity_density_",
spec.tmp, "_", Sys.Date(), ".png",
sep = ""), width = pngWidth, height = pngHeight,
units = "px", res = 96, type = "cairo")
if (isTRUE(writePNG) | isTRUE(plotR)) {
densityPlot(subset_species$Time.rad, main = plot_main_title,
rug = add.rug, ...)
mtext(paste("number of records:", nrow(subset_species)),
side = 3, line = 0)
}
if (isTRUE(writePNG))
dev.off()
}, silent = TRUE)
if (class(try_error_tmp) == "try-error")
warning(paste(toupper(spec.tmp), ": ",
try_error_tmp[1], " - SKIPPED",
sep = ""), call. = FALSE)
}
subset_species_list[[i]] <- subset_species$Time.rad
names(subset_species_list)[i] <- spec.tmp
}
}
if (allSpecies == FALSE) {
return(invisible(subset_species$Time.rad))
}
else {
return(invisible(subset_species_list))
}
}
Yet, when I try to run this new function (arguments omitted here for clarity), it can't find a function embedded within.
How can I somehow assign this function to look within the original package camtrapR for any dependencies, etc.? and why does the code output from the function not already do this?
New()
Error in dataFrameTibbleCheck(df = recordTable) :
could not find function "dataFrameTibbleCheck"
This answer here: https://stackoverflow.com/a/49277036/9096420 allows one to manually edit and save a function's code for each R session, but it is non-reproducible (not code) that can be shared or re-used.

If New is the new function copied from camtrapR then use
environment(New) <- asNamespace("camtrapR")
to ensure that the function calls in its body are looked up in the correct places.

Related

Strange R package behaviour: "could not find function"

I have some functionality which works fine outside of a package, but when I put it into a package, devtools::load_all, and try to run one of the functions (DTL_similarity_search_results_fast) , another function (DTL_similarity_search) which should be loaded by the package is not found when it gets run inside of DTL_similarity_search_results_fast.
The code is:
messagef <- function(...) message(sprintf(...))
printf <- function(...) print(sprintf(...))
pattern_to_vec <- function(pattern, as_int = F, keep_list = FALSE) {
ret <- strsplit(pattern, ",")
if(length(pattern) == 1 && !keep_list)
ret <- ret[[1]]
if(as_int){
ret <- lapply(ret, as.integer)
}
ret
}
DTL_similarity_search <- function(search_pattern = "1,2,1,2,1,2,1,2",
transformation = "interval",
database_names = "dtl,wjazzd,omnibook",
metadata_filters = '{"dtl": {}, "wjazzd": {}, "esac": {}, "omnibook": {}}',
filter_category = "0",
minimum_similarity = 1.0,
max_edit_distance = NA,
max_length_difference = 0) {
url <- suppressWarnings(httr::modify_url("https://staging-dtl-pattern-api.hfm-weimar.de/", path = "/patterns/similar"))
if(is.na(max_edit_distance)){
max_edit_distance <- purrr::map_int(pattern_to_vec(search_pattern, keep_list = T), length) %>% min()
}
messagef("[DTL API] Starting search for %s", search_pattern)
resp <- suppressWarnings(httr::POST(url, body = list( n_gram = search_pattern,
transformation = transformation,
database_names = database_names,
metadata_filters = metadata_filters,
filter_category = filter_category,
minimum_similarity = minimum_similarity,
max_edit_distance = max_edit_distance,
max_length_difference = max_length_difference, filter_category = 0),
encode = "form"))
#browser()
#print(httr::content(resp, "text"))
if (httr::http_error(resp)) {
messagef(
"[DTL API] Similarity Search request failed [%s]\n%s\n<%s>",
httr::status_code(resp),
"",#parsed$message,
""#parsed$documentation_url
)
return(NULL)
}
parsed <- jsonlite::fromJSON(httr::content(resp, "text"), simplifyVector = FALSE)
messagef("[DTL API] Retrieved search ID %s of for pattern %s", parsed$search_id, search_pattern)
parsed$search_id
}
DTL_get_results <- function(search_id) {
url <- suppressWarnings(httr::modify_url("http://staging-dtl-pattern-api.hfm-weimar.de/", path = "/patterns/get"))
#messagef("[DTL API] Retrieving results for search_id %s", search_id)
resp <- suppressWarnings(httr::GET(url, query = list(search_id = search_id)))
if (httr::http_error(resp)) {
messagef(
"[DTL API] Similarity Search request failed [%s]\n%s\n<%s>",
httr::status_code(resp),
"",#parsed$message,
""#parsed$documentation_url
)
return(NULL)
}
print(httr::content(resp, "text"))
#browser()
parsed <- jsonlite::fromJSON(httr::content(resp, "text"), simplifyVector = FALSE)
messagef("[DTL API] Retrieved %s lines for search_id %s", length(parsed), search_id)
purrr::map_dfr(parsed, function(x){
if(is.null(x$within_single_phrase)){
x$within_single_phrase <- FALSE
}
#browser()
tibble::as_tibble(x) %>% dplyr::mutate(melid = as.character(melid))
})
}
DTL_similarity_search_results <- function(search_patterns = "1,2,1,2,1,2,1,2",
transformation = "interval",
database_names = "dtl,wjazzd,omnibook",
metadata_filters = '{"dtl": {}, "wjazzd": {}, "esac": {}, "omnibook": {}}',
filter_category = "0",
minimum_similarity = 1.0,
max_edit_distance = NA,
max_length_difference = 0) {
results <- tibble::tibble()
if(is.na(max_edit_distance)){
max_edit_distance <- purrr:::map_int(pattern_to_vec(search_patterns, keep_list = T), length) %>% min()
}
for(pattern in search_patterns){
print('DTL_similarity_search')
print(DTL_similarity_search)
search_id <- DTL_similarity_search(pattern,
transformation,
database_names,
metadata_filters,
filter_category,
minimum_similarity,
max_edit_distance = max_edit_distance,
max_length_difference = max_length_difference)
if(is.null(search_id)){
next
}
ret <- DTL_get_results(search_id)
if(!is.null(ret) && nrow(ret) > 0){
ret$search_pattern <- pattern
}
results <- dplyr::bind_rows(results, ret)
}
#browser()
if(nrow(results))
results %>% dplyr::distinct(melid, start, length, .keep_all = T)
}
DTL_similarity_search_results_fast <- function(search_patterns = "1,2,1,2,1,2,1,2",
transformation = "interval",
database_names = "dtl,wjazzd,omnibook",
metadata_filters = '{"dtl": {}, "wjazzd": {}, "esac": {}, "omnibook": {}}',
filter_category = "0",
minimum_similarity = 1.0,
max_edit_distance = NA,
max_length_difference = 0){
if(is.na(max_edit_distance)){
max_edit_distance <- purrr::map_int(pattern_to_vec(search_patterns, keep_list = T), length) %>% min()
}
future::plan(future::multisession)
results <- furrr:::future_map_dfr(search_patterns, function(pattern){
print('DTL_similarity_search2')
search_id <- DTL_similarity_search(pattern,
transformation,
database_names,
metadata_filters,
filter_category,
minimum_similarity,
max_edit_distance = max_edit_distance,
max_length_difference = max_length_difference)
if(is.null(search_id)){
return(tibble::tibble())
}
ret <- DTL_get_results(search_id)
if(!is.null(ret) && nrow(ret) > 0 )ret$search_pattern <- pattern
ret
})
#browser()
results %>% dplyr::distinct(melid, start, length, .keep_all = TRUE)
}
Then after load_all() when I try to run:
res <- DTL_similarity_search_results_fast()
I get:
Error in DTL_similarity_search(pattern, transformation,
database_names, : could not find function "DTL_similarity_search
but running a similar, different function works using the same procedure:
res <- DTL_similarity_search_results()

How to use "tryCatch" to skip errors in a nested loop in R?

I am trying to load a few data with a nested-loop using pageviews. You already helped me get this result:
library("pageviews")
lang = c("it.wikipedia")
bm = c("ECB","Christine Lagarde")
x <- list(
list(),
list(),
list(),
list(),
list()
) # store results
for (i in seq_along(lang)) {
for (j in seq_along(bm)) {
x[[i]][[j]] = article_pageviews(project = lang[i], article = bm[j], platform = "all", user_type = "user", start = "2015100100", end = today(), reformat = TRUE, granularity = "daily")
}
}
The last step I need to do, however, involves reading some article for which project doesn't exist. Find an example below:
lang = c("it.wikipedia")
bm = c("Philip Lane")
x = article_pageviews(project = lang, article = bm, platform = "all", user_type = "user", start = "2015100100", end = today(), reformat = TRUE, granularity = "daily")
# Error in FUN(X[[i]], ...) :
# The date(s) you used are valid, but we either do not have data for those date(s), or the project you asked for is not loaded yet. Please check https://wikimedia.org/api/rest_v1/?doc for more information.
I would like to add this to the loop. I tried a few solutions but I don't manage to make the loop skip over if there is an error. I post below one mistaken attempt:
lang = c("it.wikipedia")
bm = c("ECB", "Christine Lagarde", "Philip Lane")
for (i in seq_along(lang)) {
for (j in seq_along(bm)) {
skip_to_next <- FALSE
tryCatch(x[[i]][[j]] = article_pageviews(project = lang[i], article = bm[j], platform = "all", user_type = "user", start = "2015100100", end = today(), reformat = TRUE, granularity = "daily"), error = function(e) {skip_to_next <<- TRUE})
if(skip_to_next) { next }
}
}
Can anyone help me run the loop and skip whenever it meets an error?
Thanks a lot!
You can use tryCatch as :
library(pageviews)
library(purrr)
lang = c("it.wikipedia")
bm = c("ECB", "Christine Lagarde", "Philip Lane")
map_df(lang, function(x) map_df(bm, function(y)
tryCatch(article_pageviews(project = x, article = y, platform = "all", user_type = "user", start = "2015100100", end = today(), reformat = TRUE, granularity = "daily"),
error = function(e) {}))) -> result

Only Table in rpivotTable

I'm using the rpivotTable package in Shiny application and I'd like to have only the choice of 'Table' for the users (no charts)
The RenderName argument is only used to choose the default display...
output$pivot <- renderRpivotTable(
rpivotTable(iris,
rendererName = "Table" )
)
Many thanks in advance !
There are multiple issues here.
you can specify renderers via the anonymos renderers argument in rpivotTable(). I have the JS code form here.
however, there is a bug when only selecting one option. In this case, rpivotTable() wraps the argument in a list again (see the Map() call in the original function code) and the forwarding to JS fails.
Therefore, I accounted for this issue and extended the function a bit. Play around with aggregators/renderers to see how it behaves differently to the original rpivotTable() function.
# define own function
my_rpivotTable <- function (data, rows = NULL, cols = NULL, aggregatorName = NULL,
vals = NULL, rendererName = NULL, sorter = NULL, exclusions = NULL,
inclusions = NULL, locale = "en", subtotals = FALSE, ...,
width = 800, height = 600, elementId = NULL)
{
if (length(intersect(class(data), c("data.frame", "data.table",
"table", "structable", "ftable"))) == 0) {
stop("data should be a data.frame, data.table, or table",
call. = F)
}
if (length(intersect(c("table", "structable", "ftable"),
class(data))) > 0)
data <- as.data.frame(data)
params <- list(rows = rows, cols = cols, aggregatorName = aggregatorName,
vals = vals, rendererName = rendererName, sorter = sorter,
...)
params <- Map(function(p) {
# added to the class check -------------------------------------------------
if (length(p) == 1 && class(p[[1]]) != "JS_EVAL") {
p = list(p)
}
return(p)
}, params)
par <- list(exclusions = exclusions, inclusions = inclusions)
params <- c(params, par)
params <- Filter(Negate(is.null), params)
x <- list(data = data, params = params, locale = locale,
subtotals = subtotals)
htmlwidgets::createWidget(name = "rpivotTable", x, width = width,
height = height, elementId = elementId, package = "rpivotTable")
}
# create the pivot table
my_rpivotTable(
expand.grid(LETTERS, 1:3),
aggregatorName = "Count",
aggregators = list(Sum = htmlwidgets::JS('$.pivotUtilities.aggregators["Sum"]'),
Count = htmlwidgets::JS('$.pivotUtilities.aggregators["Count"]')),
rendererName = "fancyTable",
renderers = list(fancyTable = htmlwidgets::JS('$.pivotUtilities.renderers["Table"]'))
)

Function input used as string

saving_ggplot <- function(name = 'default', plotname = last_plot()) {
image_name = paste(name, ".png", sep="")
ggsave(image_name, plot = plotname,
scale = 1,
dpi = 300, limitsize = TRUE)
}
This is my function which saves a ggplot. However, I for the life of me cannot figure out how to take the name argument as a string.
for example if someone runes saving_ggplot(FILENAME, PLOTNAME)
it will just say no object FILENAME. In python I can just capture it and use it as str(), but using as.character or toString in R still doesn't work.
Error:
saving_ggplot(weightvsageTEST, weightvsageplot)
Error in paste(name, ".png", sep = "") :
object 'weightvsageTEST' not found
Successful call using ggsave:
ggsave('weightvsage.png', plot = last_plot(),
scale = 1,
dpi = 300, limitsize = TRUE)
You can use substitute():
saving_ggplot <- function(name, plotname) {
image_name = paste0(substitute(name), ".png") # paste0 removes need for sep arg
ggsave(image_name, plot = plotname,
scale = 1,
dpi = 300, limitsize = TRUE)
}
saving_ggplot(foo, p) # saves foo.png
Alternately, if you want to stay within tidyverse quasiquotation syntax, use enexpr() instead:
enexpr(name) # instead of substitute(name)
Data:
N <- 100
df <- data.frame(x=rnorm(n=N), y=rnorm(n=N))
p <- ggplot(df, aes(x,y)) + geom_smooth()

Redefining help_console function to get help on function from a given package

Following is the function to get help on R functions. See below:
help_console <-
function (topic, format = c("text", "html", "latex", "Rd"), lines = NULL,
before = NULL, after = NULL)
{
format = match.arg(format)
if (!is.character(topic))
topic <- deparse(substitute(topic))
helpfile = utils:::.getHelpFile(help(topic))
hs <- capture.output(switch(format, text = tools:::Rd2txt(helpfile),
html = tools:::Rd2HTML(helpfile), latex = tools:::Rd2latex(helpfile),
Rd = tools:::prepare_Rd(helpfile)))
if (!is.null(lines))
hs <- hs[lines]
hs <- c(before, hs, after)
cat(hs, sep = "\n")
invisible(hs)
}
help_console(topic="lm", format = "text", lines=1)
Fitting Linear Models
Now I want to redefine this function to get help on R function from given package. Here is my MWE
help_console2 <-
function (topic, pkg, format = c("text", "html", "latex", "Rd"), lines = NULL,
before = NULL, after = NULL)
{
format = match.arg(format)
if (!is.character(topic))
topic <- deparse(substitute(topic))
if (!is.character(pkg))
topic <- deparse(substitute(pkg))
helpfile = utils:::.getHelpFile(help(pkg, topic))
hs <- capture.output(switch(format, text = tools:::Rd2txt(helpfile),
html = tools:::Rd2HTML(helpfile), latex = tools:::Rd2latex(helpfile),
Rd = tools:::prepare_Rd(helpfile)))
if (!is.null(lines))
hs <- hs[lines]
hs <- c(before, hs, after)
cat(hs, sep = "\n")
invisible(hs)
}
help_console2(topic="lm", pkg="stats", format = "text", lines=1)
Error in find.package(if (is.null(package)) loadedNamespaces() else package, :
there is no package called ‘topic’
This function is throwing error.
You have the wrong argument order and need to outsmart non-standard evaluation:
help_console2 <-
function (topic, pkg, format = c("text", "html", "latex", "Rd"), lines = NULL,
before = NULL, after = NULL)
{
format = match.arg(format)
if (!is.character(topic))
topic <- deparse(substitute(topic))
if (!is.character(pkg))
topic <- deparse(substitute(pkg))
helpfile = utils:::.getHelpFile(do.call(help, list(topic=topic, package=pkg)))
hs <- capture.output(switch(format, text = tools:::Rd2txt(helpfile),
html = tools:::Rd2HTML(helpfile), latex = tools:::Rd2latex(helpfile),
Rd = tools:::prepare_Rd(helpfile)))
if (!is.null(lines))
hs <- hs[lines]
hs <- c(before, hs, after)
cat(hs, sep = "\n")
invisible(hs)
}
help_console2(topic="lm", pkg="stats", format = "text", lines=1)
#Fitting Linear Models

Resources