vapply: values must be length 11 - r

I'm using the function drive_time() from the placement package by Derek Darves, which outputs the time and length between two points via Google Maps.
However, not even the example code works for me:
howfar_kms <- drive_time(
address="350 5th Ave, New York, NY 10118, USA",
dest="1600 Amphitheatre Pkwy, Mountain View, CA 94043",
auth="standard_api", privkey="", clean=FALSE,
add_date='today', verbose=FALSE, travel_mode="bicycling",
units="imperial"
)
It gives this error:
Error in vapply(json, function(x) { :
values must be length 11,
but FUN(X[[1]]) result is length 0
It should be noted that yesterday the very same piece of code worked. I guess this is a problem of being dependent on things like real-time traffic info and so on.
Anyway I don't know how to work it out because vapply is part of the inner working of the function I guess.
Do you have any idea?
This is the full function, thanks #lmo for the tip.
function (address, dest, auth = "standard_api", privkey = NULL,
clientid = NULL, clean = "TRUE", travel_mode = "driving",
units = "metric", verbose = FALSE, add_date = "none", language = "en-EN",
messages = FALSE, small = FALSE)
{
options(stringsAsFactors = F)
if (!grepl("standard_api|work", auth))
stop("Invalid auth paramater. Must be 'standard_api' or 'work'.")
if (is.null(privkey))
stop("You must specify a valid API key or an empty string (''). To request a key, see:\n\t https://developers.google.com/maps/documentation/javascript/get-api-key#get-an-api-key")
if (auth == "work" & is.null(clientid))
stop("You must specify a client ID with the work authentication method!")
if (!grepl("driving|bicycling|transit|walking", travel_mode,
ignore.case = TRUE))
stop("You must specify a valid travel mode.")
if (!grepl("metric|imperial", units))
stop("Invalid units paramater. Must be 'metric' or 'imperial'")
if (length(address) > 1 & length(address) != length(dest))
stop("Address must be singular or the same length as destination!")
if (!is.vector(c(address, dest), mode = "character"))
stop("Address and destination must be character vectors!")
if (!grepl("today|fuzzy|none", add_date))
stop("Invalid add_date paramater. Must be 'today', 'fuzzy', or 'none'")
if (privkey == "" & travel_mode == "transit")
stop("You must specify a valid API key to use the transit mode!")
if (!is.logical(messages))
stop("messages must be logical! Please choose TRUE or FALSE.")
if (clean) {
if (verbose)
cat("Cleaning origin addresses...\n")
address <- placement::address_cleaner(address, verbose = verbose)
if (verbose)
cat("Cleaning destination addresses...\n")
dest <- placement::address_cleaner(dest, verbose = verbose)
}
not_nambia <- function(x) {
x[is.na(x)] <- ""
return(x)
}
address <- not_nambia(address)
dest <- not_nambia(dest)
enc <- urltools::url_encode(address)
dest <- urltools::url_encode(dest)
if (auth == "standard_api") {
inbound <- data.frame(address = enc, dest = dest)
baserl <- "https://maps.googleapis.com/maps/api/distancematrix/json?origins="
inbound$full_url <- paste0(baserl, inbound$address, "&destinations=",
inbound$dest, "&units=", tolower(units), "&mode=",
tolower(travel_mode), "&language=", language, "&key=",
privkey)
togoogle <- inbound$full_url
}
if (auth == "work") {
togoogle <- placement::google_encode64(enc, dest = dest,
gmode = "dtime", privkey = privkey, clientid = clientid,
verbose = verbose, units = units)
}
if (verbose)
cat("Sending locations (n=", length(togoogle), ") to Google for distance calculation...\n",
sep = "")
json <- placement::pull_geo_data(togoogle, tmout = 10, messages = messages)
if (json[[1]]$status == "REQUEST_DENIED") {
stop(paste0("Request sent to Google, but response returned REQUEST_DENIED. Error details:\n",
json[[1]]$error_message))
}
coord <- t(vapply(json, function(x) {
if (!is.null(x$status)) {
if (x$status == "OK") {
if (!is.null(x$rows$elements[[1]]$status)) {
if (x$rows$elements[[1]]$status == "OK") {
origin <- as.character(x$origin_addresses)
destination <- as.character(x$destination_addresses)
dist_num <- as.character(x$rows$elements[[1]]$distance$value/1000)
if (units == "imperial")
dist_num <- as.character(as.numeric(dist_num) *
0.621371)
dist_txt <- as.character(x$rows$elements[[1]]$distance$text)
time_secs <- as.character(x$rows$elements[[1]]$duration$value)
time_mins <- as.character(as.numeric(time_secs) *
0.0166667)
time_hours <- as.character(as.numeric(time_secs) *
0.000277778)
time_txt <- as.character(x$rows$elements[[1]]$duration$text)
return_stat <- as.character(x$rows$elements[[1]]$status)
status <- as.character(x$status)
error_message <- ""
return(c(origin, destination, dist_num, dist_txt,
time_secs, time_mins, time_hours, time_txt,
return_stat, status, error_message))
}
else {
return(c(as.character(x$origin_addresses),
as.character(x$destination_addresses),
rep(NA, 6), x$rows$elements[[1]]$status,
x$status, ""))
}
}
}
else if (x$status == "CONNECTION_ERROR" & !is.null(x$error_message)) {
return(c(rep(NA, 9), x$status, x$error_message))
}
}
else {
return(c(rep(NA, 10), "Non-conforming response object: check source data/url for this record"))
}
}, character(11)))
if (is.matrix(coord)) {
out <- as.data.frame(coord)
}
else if (length(coord) == 11) {
out <- data.frame(t(unlist(coord)))
}
colnames(out) <- c("origin", "destination", "dist_num", "dist_txt",
"time_secs", "time_mins", "time_hours", "time_txt", "return_stat",
"status", "error_message")
nums <- c("dist_num", "time_secs", "time_mins", "time_hours")
out[, nums] <- vapply(out[, nums], function(x) {
x <- round(as.numeric(x), digits = 2)
return(x)
}, numeric(nrow(out)))
out$input_url <- togoogle
if (small)
out <- out[, c("dist_num", "time_hours")]
if (!add_date == "none") {
out$geocode_dt <- Sys.Date()
if (add_date == "fuzzy")
out$geocode_dt <- out$geocode_dt + stats::runif(nrow(out),
1, 30)
}
if (verbose) {
cat("Finished.", nrow(out[out$return_stat == "OK", ]),
"of", nrow(out), "distance calculations were successful.\n")
if (units == "imperial") {
len <- "miles"
}
else {
len <- "kilometers"
}
message("Note: numeric distances in the 'dist_num' column are expressed in ",
len, ".\n")
}
return(out)
}

Related

Creating Binary Search Tree in R

I have this code for creating a Binary Search Tree in a R6 class.
Creating a Node & BST class. In BST class, I am defining insert_recur function to create the BST by appropriately inserting the data.
library(R6)
Node <- R6Class(
classname = 'Node',
public = list(
val = NULL,
left = NULL,
right = NULL,
initialize = function(val = NULL, left = NULL, right = NULL){
self$val <- val
self$left <- left
self$right <- right
}
)
)
BST <- R6Class(
classname = 'BST',
public = list(
root = NULL,
# node = NULL,
insert = function(data){
if(is.null(self$root)){
self$node <- Node$new(data)
}else{
self$insert_recur(data, self$root)
}
},
insert_recur = function(data, cur_node){
if(data < cur_node$val){
if(is.null(cur_node$self)){
cur_node$left <- Node$new(data)
}else{
insert_recur(data, cur_node$left)
}
}else if(data > cur_node$val){
if(is.null(cur_node$self)){
cur_node$right <- Node$new(data)
}else{
insert_recur(data, cur_node$right)
}
}else{
print('value already in tree')
}
},
get_height = function(cur_node){
if(is.null(cur_node$val)){
return(-1)
}else{
return(max(self$get_height(cur_node$left),self$get_height(cur_node$right))+1)
}
}
)
)
bst <- BST$new()
bst$insert(3)
bst$insert(2)
bst$insert(1)
bst$insert(5)
bst$insert(6)
bst$insert(4)
bst$insert(7)
However I am getting this error -
Error in self$node <- Node$new(data) : cannot add bindings to a locked environment
If I put node <- NULL in the BST class, then the recursion fails & all nodes are NULL.
What will be the correct implementation?
Your Node implementation is fine. The BST isn't quite right though. It should have a NULL root node only. The problem lies in your insert_recur function. It's not possible for cur_node$self to ever be NULL, and the logic would seem to indicate that your if statements should be checking for the absence of cur_node$left and cur_node$right instead. Also, you need to remember to use self$insert_recur. The logic of your get_height argument doesn't seem right to me either. The following implementation seems to work as expected:
BST <- R6Class(
classname = 'BST',
public = list(
root = NULL,
insert = function(data) {
if(is.null(self$root)) {
self$root <- Node$new(data)
} else {
self$insert_recur(data, self$root)
}
},
insert_recur = function(data, cur_node) {
if(data < cur_node$val) {
if(is.null(cur_node$left)) {
cur_node$left <- Node$new(data)
} else {
self$insert_recur(data, cur_node$left)
}
} else if(data > cur_node$val){
if(is.null(cur_node$right)){
cur_node$right <- Node$new(data)
}else{
self$insert_recur(data, cur_node$right)
}
}else{
print('value already in tree')
}
},
get_height = function(cur_node){
if(is.null(cur_node$left) & is.null(cur_node$right)){
return(0)
}else{
return(max(self$get_height(cur_node$left),
self$get_height(cur_node$right)) + 1)
}
}
)
)
This allows
bst <- BST$new()
bst$insert(3)
bst$insert(2)
bst$insert(1)
bst$insert(5)
bst$insert(6)
bst$insert(4)
bst$insert(7)
bst$get_height(bst$root)
#> [1] 3
bst$get_height(bst$root$right)
#> [1] 2
Created on 2022-09-24 with reprex v2.0.2

twitchr::get_videos gives Internal error in `vec_slice_impl()`: Unexpected `NULL`

I'm trying to get video information by user with get_videos function for twitchr package in R.
The console will give me the following output, when I run it:
videos <- get_videos(user_id = 613890167,clean_json = T)
Error: Internal error in `vec_slice_impl()`: Unexpected `NULL`.
Run `rlang::last_error()` to see where the error occurred.
> rlang::last_error()
<error/rlang_error>
Internal error in `vec_slice_impl()`: Unexpected `NULL`.
Backtrace:
1. twitchr::get_videos(user_id = 613890167)
8. dplyr::bind_rows(.)
9. vctrs::vec_rbind(!!!dots, .names_to = .id)
Run `rlang::last_trace()` to see the full context.
> rlang::last_trace()
<error/rlang_error>
Internal error in `vec_slice_impl()`: Unexpected `NULL`.
Backtrace:
█
1. ├─twitchr::get_videos(user_id = 613890167)
2. │ └─twitchr:::make_request(...)
3. │ └─twitchr:::clean_videos(response_content)
4. │ └─`%>%`(...)
5. ├─twitchr:::date_formatter(.)
6. │ └─`%>%`(...)
7. ├─dplyr::mutate(...)
8. └─dplyr::bind_rows(.)
9. └─vctrs::vec_rbind(!!!dots, .names_to = .id)
10. └─(function () ...
it seems to work with videos <- get_videos (user_id = 613890167, clean_json = F).
So i tried looking for the error inside the get_videos function:
function (id = NULL, user_id = NULL, game_id = NULL, after = NULL,
before = NULL, first = NULL, language = NULL, period = NULL,
sort = NULL, type = NULL, clean_json = TRUE)
{
d <- make_request(end_point = "videos", clean_json = clean_json,
id = id, user_id = user_id, game_id = game_id, after = after,
before = before, first = first, language = language,
period = period, sort = sort, type = type)
return(d)
}
in make_request
function (end_point, ..., clean_json = TRUE)
{
formatted_params <- format_parameters(...)
base_url <- "https://api.twitch.tv/helix/"
url_end_point <- glue::glue("{base_url}{end_point}{formatted_params}")
response <- httr::GET(url = url_end_point)
check_status(response)
response_content <- httr::content(response)
if (length(response_content$data) == 0) {
usethis::ui_warn("The request is successful, however, there is no data in the response.")
return(NULL)
}
if (clean_json == TRUE) {
if (end_point == "bits/cheermotes") {
result <- clean_bits_cheermotes(response_content)
}
if (end_point == "videos") {
result <- clean_videos(response_content)
}
if (end_point == "users") {
result <- clean_users(response_content)
}
if (end_point == "games") {
result <- clean_games(response_content)
}
if (end_point == "games/top") {
result <- clean_top_games(response_content)
}
if (end_point == "clips") {
result <- clean_clips(response_content)
}
if (end_point == "search/channels") {
result <- clean_search_channels(response_content)
}
if (end_point == "tags/streams") {
result <- clean_get_all_stream_tags(response_content)
}
if (end_point == "streams/tags") {
result <- clean_stream_tags(response_content)
}
if (end_point == "search/categories") {
result <- clean_search_categories(response_content)
}
if (end_point == "users/follows") {
result <- clean_get_follows(response_content)
}
}
else {
result <- response_content
}
return(result)
}
in clean_videos
function (response_content)
{
data_clean <- response_content %>% purrr::pluck("data") %>%
dplyr::bind_rows() %>% date_formatter()
return_list <- list(data = data_clean, pagination = response_content$pagination$cursor)
return(return_list)
}
the problem seems to be caused by dplyr :: bind_rows (), indeed:
videos <- get_videos(user_id = 238617149,clean_json = F)
xx=videos %>% purrr::pluck("data")
dplyr::bind_rows(xx)
Error: Internal error in `vec_slice_impl()`: Unexpected `NULL`.
Run `rlang::last_error()` to see where the error occurred.
data.table::rbindlist(xx) instead of dplyr::bind_rows(xx) seems to work.
But if I define the function clean_videos writing data.table::rbindlist(xx) instead of dplyr::bind_rows(xx):
clean_videos = function (response_content)
{
data_clean <- response_content %>% purrr::pluck("data") %>%
data.table::rbindlist() %>% date_formatter()
return_list <- list(data = data_clean, pagination = response_content$pagination$cursor)
return(return_list)
}
when I try again videos <- get_videos(user_id = 613890167, clean_json = T), the console gives me the same error as output.
How can I solve the problem?

How to debug function which is getting called throuh validate_and_run() in R?

I want to debug functions in ShadowCAT package. https://github.com/Karel-Kroeze/ShadowCAT/tree/master/R
Take any internal functions from this package, they are getting called via validate_and_run() function. If I go though it I am directly presented an output and I am not able to run through each line of the code I am interested in. What I think validate_and_run() creating an environment to call the functions.
For e.g. I am trying to debug shadowcat function from the package using following code:
library(devtools)
install_github("Karel-Kroeze/ShadowCAT")
library(ShadowCAT)
debug(shadowcat)
alpha_beta <- simulate_testbank(model = "GPCM", number_items = 100,
number_dimensions = 3, number_itemsteps = 3)
model <- "GPCM"
start_items <- list(type = 'fixed', item_keys = c("item33", "item5", "item23"), n = 3)
stop_test <- list(min_n = 4, max_n = 30, target = c(.1, .1, .1))
estimator <- "maximum_aposteriori"
information_summary <- "posterior_determinant"
prior_form <- "normal"
prior_parameters <- list(mu = c(0, 0, 0), Sigma = diag(3))
# Initial call: get key of first item to adminster
call1 <- shadowcat(answers = NULL, estimate = c(0, 0, 0), variance = as.vector(diag(3) * 25),
model = model, alpha = alpha_beta$alpha, beta = alpha_beta$beta,
start_items = start_items, stop_test = stop_test,
estimator = estimator, information_summary = information_summary,
prior_form = prior_form, prior_parameters = prior_parameters)
In above shadowcat() function there ane many internal functions written but I do not see they are getting called anywhere in the shadowcat(). My speculation is that it is getting called in validate_and_run() function.
My question is how can I debug those internal functions inside the shadowcat() and see what each variable is storing and what are the inputs of the internal functions when they are getting called?
EDIT 1:
In any usual R function, when one debugs it, you can move your debugging cursor (yellow highlighted line) line by line by clicking on next in RStudio. Also, once you have gone over that line of code , you can see the value of the variable by printing the variable name on console. This I am not able to do in shadowcat() function. Internal function codes are written but they are never called in visible form. I need to see where they are getting called and need to debug through them
Any leads appreciated.
EDIT 2
Main body of the code:
function (answers, estimate, variance, model, alpha, beta, start_items,
stop_test, estimator, information_summary, prior_form = NULL,
prior_parameters = NULL, guessing = NULL, eta = NULL, constraints_and_characts = NULL,
lower_bound = NULL, upper_bound = NULL, safe_eap = FALSE,
eap_estimation_procedure = "riemannsum")
{
result <- function() {
switch_to_maximum_aposteriori <- estimator == "maximum_likelihood" &&
!is.null(lower_bound) && !is.null(upper_bound)
estimator <- get_estimator(switch_to_maximum_aposteriori = switch_to_maximum_aposteriori)
prior_form <- get_prior_form(switch_to_maximum_aposteriori = switch_to_maximum_aposteriori)
prior_parameters <- get_prior_parameters(switch_to_maximum_aposteriori = switch_to_maximum_aposteriori)
beta <- get_beta()
guessing <- get_guessing()
number_items <- nrow(alpha)
number_dimensions <- ncol(alpha)
number_itemsteps_per_item <- number_non_missing_cells_per_row(beta)
lp_constraints_and_characts <- get_lp_constraints_and_characts(number_items = number_items)
item_keys <- rownames(alpha)
item_keys_administered <- names(answers)
item_keys_available <- get_item_keys_available(item_keys_administered = item_keys_administered,
item_keys = item_keys)
attr(estimate, "variance") <- matrix(variance, ncol = number_dimensions)
estimate <- update_person_estimate(estimate = estimate,
answers_vector = unlist(answers), item_indices_administered = match(item_keys_administered,
item_keys), number_dimensions = number_dimensions,
alpha = alpha, beta = beta, guessing = guessing,
number_itemsteps_per_item = number_itemsteps_per_item,
estimator = estimator, prior_form = prior_form, prior_parameters = prior_parameters)
continue_test <- !terminate_test(number_answers = length(answers),
estimate = estimate, min_n = stop_test$min_n, max_n = stop_test$max_n,
variance_target = stop_test$target, cutoffs = stop_test$cutoffs)
if (continue_test) {
index_new_item <- get_next_item(start_items = start_items,
information_summary = information_summary, lp_constraints = lp_constraints_and_characts$lp_constraints,
lp_characters = lp_constraints_and_characts$lp_chars,
estimate = estimate, model = model, answers = unlist(answers),
prior_form = prior_form, prior_parameters = prior_parameters,
available = match(item_keys_available, item_keys),
administered = match(item_keys_administered,
item_keys), number_items = number_items, number_dimensions = number_dimensions,
estimator = estimator, alpha = alpha, beta = beta,
guessing = guessing, number_itemsteps_per_item = number_itemsteps_per_item,
stop_test = stop_test, eap_estimation_procedure = eap_estimation_procedure)
key_new_item <- item_keys[index_new_item]
}
else {
key_new_item <- NULL
}
list(key_new_item = as.scalar2(key_new_item), continue_test = as.scalar2(continue_test),
estimate = as.vector(estimate), variance = as.vector(attr(estimate,
"variance")), answers = answers)
}
update_person_estimate <- function(estimate, answers_vector,
item_indices_administered, number_dimensions, alpha,
beta, guessing, number_itemsteps_per_item, estimator,
prior_form, prior_parameters) {
if (length(answers) > start_items$n)
estimate_latent_trait(estimate = estimate, answers = answers_vector,
prior_form = prior_form, prior_parameters = prior_parameters,
model = model, administered = item_indices_administered,
number_dimensions = number_dimensions, estimator = estimator,
alpha = alpha, beta = beta, guessing = guessing,
number_itemsteps_per_item = number_itemsteps_per_item,
safe_eap = safe_eap, eap_estimation_procedure = eap_estimation_procedure)
else estimate
}
get_item_keys_available <- function(item_keys_administered,
item_keys) {
if (is.null(item_keys_administered))
item_keys
else item_keys[-which(item_keys %in% item_keys_administered)]
}
get_beta <- function() {
if (model == "GPCM" && is.null(beta) && !is.null(eta))
row_cumsum(eta)
else beta
}
get_guessing <- function() {
if (is.null(guessing))
matrix(0, nrow = nrow(as.matrix(alpha)), ncol = 1,
dimnames = list(rownames(alpha), NULL))
else guessing
}
get_estimator <- function(switch_to_maximum_aposteriori) {
if (switch_to_maximum_aposteriori)
"maximum_aposteriori"
else estimator
}
get_prior_form <- function(switch_to_maximum_aposteriori) {
if (switch_to_maximum_aposteriori)
"uniform"
else prior_form
}
get_prior_parameters <- function(switch_to_maximum_aposteriori) {
if (switch_to_maximum_aposteriori)
list(lower_bound = lower_bound, upper_bound = upper_bound)
else prior_parameters
}
get_lp_constraints_and_characts <- function(number_items) {
if (is.null(constraints_and_characts))
NULL
else constraints_lp_format(max_n = stop_test$max_n, number_items = number_items,
characteristics = constraints_and_characts$characteristics,
constraints = constraints_and_characts$constraints)
}
validate <- function() {
if (is.null(estimate))
return(add_error("estimate", "is missing"))
if (is.null(variance))
return(add_error("variance", "is missing"))
if (!is.vector(variance))
return(add_error("variance", "should be entered as vector"))
if (sqrt(length(variance)) != round(sqrt(length(variance))))
return(add_error("variance", "should be a covariance matrix turned into a vector"))
if (is.null(model))
return(add_error("model", "is missing"))
if (is.null(alpha))
return(add_error("alpha", "is missing"))
if (is.null(start_items))
return(add_error("start_items", "is missing"))
if (is.null(stop_test))
return(add_error("stop_test", "is missing"))
if (is.null(estimator))
return(add_error("estimator", "is missing"))
if (is.null(information_summary))
return(add_error("information_summary", "is missing"))
if (!is.matrix(alpha) || is.null(rownames(alpha)))
return(add_error("alpha", "should be a matrix with item keys as row names"))
if (!is.null(beta) && (!is.matrix(beta) || is.null(rownames(beta))))
return(add_error("beta", "should be a matrix with item keys as row names"))
if (!is.null(eta) && (!is.matrix(eta) || is.null(rownames(eta))))
return(add_error("eta", "should be a matrix with item keys as row names"))
if (!is.null(guessing) && (!is.matrix(guessing) || ncol(guessing) !=
1 || is.null(rownames(guessing))))
return(add_error("guessing", "should be a single column matrix with item keys as row names"))
if (!is.null(start_items$type) && start_items$type ==
"random_by_dimension" && length(start_items$n_by_dimension) %not_in%
c(1, length(estimate)))
return(add_error("start_items", "length of n_by_dimension should be a scalar or vector of the length of estimate"))
if (!row_names_are_equal(rownames(alpha), list(alpha,
beta, eta, guessing)))
add_error("alpha_beta_eta_guessing", "should have equal row names, in same order")
if (!is.null(beta) && !na_only_end_rows(beta))
add_error("beta", "can only contain NA at the end of rows, no values allowed after an NA in a row")
if (!is.null(eta) && !na_only_end_rows(eta))
add_error("eta", "can only contain NA at the end of rows, no values allowed after an NA in a row")
if (length(estimate) != ncol(alpha))
add_error("estimate", "length should be equal to the number of columns of the alpha matrix")
if (length(estimate)^2 != length(variance))
add_error("variance", "should have a length equal to the length of estimate squared")
if (is.null(answers) && !is.positive.definite(matrix(variance,
ncol = sqrt(length(variance)))))
add_error("variance", "matrix is not positive definite")
if (model %not_in% c("3PLM", "GPCM", "SM", "GRM"))
add_error("model", "of unknown type")
if (model != "GPCM" && is.null(beta))
add_error("beta", "is missing")
if (model == "GPCM" && is.null(beta) && is.null(eta))
add_error("beta_and_eta", "are both missing; define at least one of them")
if (model == "GPCM" && !is.null(beta) && !is.null(eta) &&
!all(row_cumsum(eta) == beta))
add_error("beta_and_eta", "objects do not match")
if (estimator != "maximum_likelihood" && is.null(prior_form))
add_error("prior_form", "is missing")
if (estimator != "maximum_likelihood" && is.null(prior_parameters))
add_error("prior_parameters", "is missing")
if (!is.null(prior_form) && prior_form %not_in% c("normal",
"uniform"))
add_error("prior_form", "of unknown type")
if (!is.null(prior_form) && !is.null(prior_parameters) &&
prior_form == "uniform" && (is.null(prior_parameters$lower_bound) ||
is.null(prior_parameters$upper_bound)))
add_error("prior_form_is_uniform", "so prior_parameters should contain lower_bound and upper_bound")
if (!is.null(prior_form) && !is.null(prior_parameters) &&
prior_form == "normal" && (is.null(prior_parameters$mu) ||
is.null(prior_parameters$Sigma)))
add_error("prior_form_is_normal", "so prior_parameters should contain mu and Sigma")
if (!is.null(prior_parameters$mu) && length(prior_parameters$mu) !=
length(estimate))
add_error("prior_parameters_mu", "should have same length as estimate")
if (!is.null(prior_parameters$Sigma) && (!is.matrix(prior_parameters$Sigma) ||
!all(dim(prior_parameters$Sigma) == c(length(estimate),
length(estimate))) || !is.positive.definite(prior_parameters$Sigma)))
add_error("prior_parameters_sigma", "should be a square positive definite matrix, with dimensions equal to the length of estimate")
if (!is.null(prior_parameters$lower_bound) && !is.null(prior_parameters$upper_bound) &&
(length(prior_parameters$lower_bound) != length(estimate) ||
length(prior_parameters$upper_bound) != length(estimate)))
add_error("prior_parameters_bounds", "should contain lower and upper bound of the same length as estimate")
if (is.null(stop_test$max_n))
add_error("stop_test", "contains no max_n")
if (!is.null(stop_test$max_n) && stop_test$max_n > nrow(alpha))
add_error("stop_test_max_n", "is larger than the number of items in the item bank")
if (!is.null(stop_test$max_n) && !is.null(stop_test$cutoffs) &&
(!is.matrix(stop_test$cutoffs) || nrow(stop_test$cutoffs) <
stop_test$max_n || ncol(stop_test$cutoffs) !=
length(estimate) || any(is.na(stop_test$cutoffs))))
add_error("stop_test_cutoffs", "should be a matrix without missing values, and number of rows equal to max_n and number of columns equal to the number of dimensions")
if (start_items$n == 0 && information_summary == "posterior_expected_kullback_leibler")
add_error("start_items", "requires n > 0 for posterior expected kullback leibler information summary")
if (!is.null(start_items$type) && start_items$type ==
"random_by_dimension" && length(start_items$n_by_dimension) ==
length(estimate) && start_items$n != sum(start_items$n_by_dimension))
add_error("start_items_n", "contains inconsistent information. Total length of start phase and sum of length per dimension do not match (n != sum(n_by_dimension)")
if (!is.null(start_items$type) && start_items$type ==
"random_by_dimension" && length(start_items$n_by_dimension) ==
1 && start_items$n != sum(rep(start_items$n_by_dimension,
length(estimate))))
add_error("start_items_n", "contains inconsistent information. Total length of start phase and sum of length per dimension do not match")
if (!is.null(stop_test$cutoffs) && !is.matrix(stop_test$cutoffs))
add_error("stop_test", "contains cutoff values in non-matrix format")
if (!all(names(answers) %in% rownames(alpha)))
add_error("answers", "contains non-existing key")
if (estimator %not_in% c("maximum_likelihood", "maximum_aposteriori",
"expected_aposteriori"))
add_error("estimator", "of unknown type")
if (information_summary %not_in% c("determinant", "posterior_determinant",
"trace", "posterior_trace", "posterior_expected_kullback_leibler"))
add_error("information_summary", "of unknown type")
if (estimator == "maximum_likelihood" && information_summary %in%
c("posterior_determinant", "posterior_trace", "posterior_expected_kullback_leibler"))
add_error("estimator_is_maximum_likelihood", "so using a posterior information summary makes no sense")
if (estimator != "maximum_likelihood" && (!is.null(lower_bound) ||
!is.null(upper_bound)))
add_error("bounds", "can only be defined if estimator is maximum likelihood")
if (!is.null(lower_bound) && length(lower_bound) %not_in%
c(1, length(estimate)))
add_error("lower_bound", "length of lower bound should be a scalar or vector of the length of estimate")
if (!is.null(upper_bound) && length(upper_bound) %not_in%
c(1, length(estimate)))
add_error("upper_bound", "length of upper bound should be a scalar or vector of the length of estimate")
if (!no_missing_information(constraints_and_characts$characteristics,
constraints_and_characts$constraints))
add_error("constraints_and_characts", "constraints and characteristics should either be defined both or not at all")
if (!characteristics_correct_format(constraints_and_characts$characteristics,
number_items = nrow(alpha)))
add_error("characteristics", "should be a data frame with number of rows equal to the number of items in the item bank")
if (!constraints_correct_structure(constraints_and_characts$constraints))
add_error("constraints_structure", "should be a list of length three lists, with elements named 'name', 'op', 'target'")
if (!constraints_correct_names(constraints_and_characts$constraints,
constraints_and_characts$characteristics))
add_error("constraints_name_elements", "should be defined as described in the details section of constraints_lp_format()")
if (!constraints_correct_operators(constraints_and_characts$constraints))
add_error("constraints_operator_elements", "should be defined as described in the details section of constraints_lp_format()")
if (!constraints_correct_targets(constraints_and_characts$constraints))
add_error("constraints_target_elements", "should be defined as described in the details section of constraints_lp_format()")
}
invalid_result <- function() {
list(errors = errors())
}
validate_and_run()
}
EDIT 3
validate_and_run() function:
function ()
{
.errors <- list()
add_error <- function(key, value = TRUE) {
.errors[key] <<- value
}
errors <- function() {
.errors
}
validate_and_runner <- function() {
if (exists("validate", parent.frame(), inherits = FALSE))
do.call("validate", list(), envir = parent.frame())
if (exists("test_inner_functions", envir = parent.frame(n = 2),
inherits = FALSE))
get("result", parent.frame())
else if (length(errors()) == 0)
do.call("result", list(), envir = parent.frame())
else do.call("invalid_result", list(), envir = parent.frame())
}
for (n in ls(environment())) assign(n, get(n, environment()),
parent.frame())
do.call("validate_and_runner", list(), envir = parent.frame())
}

R Code gmapsdistance

I have the following code used to find the travel time between two locations. I am using vba to call the script which is why the command args shows up at the top but for testing purposes I am just setting the variables. This was working until today (didn't change anything) and now I keep getting this error once i run the results line: Error in rowXML[[dur]] : subscript out of bounds.
Does anyone have any idea what could be causing this or what it means?
Code:
#install and load necessary packages
#install.packages("gmapsdistance")
#install.packages("devtools")
args<-commandArgs(trailingOnly=T)
library("gmapsdistance")
library("devtools")
devtools::install_github("rodazuero/gmapsdistance")
#input variables from excel
orig <- args[1]
dest <- args[2]
filePath <- args[3]
api_key <- args[4]
orig <- "London"
dest <- "Paris"
filePath <- "C:/Users/gabby/Documents/SeniorYear/SeniorDesign/TravelTimes/Travel_Times.csv"
api_key <- "############################"
set.api.key(api_key)
#calls google maps and finds the time
results = gmapsdistance(origin = c(orig, dest), destination = c(dest, orig), mode = "driving", traffic_model = "best_guess",
key = api_key, combinations = "pairwise", shape = "wide")
#put results in a data frame
results2 <- data.frame(results)
#rename the column headings
names(results2) <- c("Origin","Destination", "Time", "X1","X2","Distance","X3","X4","Status")
#delete repeated origin/destination columns
results2$X1 <- NULL
results2$X2 <- NULL
results2$X3 <- NULL
results2$X4 <- NULL
#convert seconds to minutes
results2$Time <- results2$Time/60
#convert meters to miles
results2$Distance <- results2$Distance*0.000621371
#add extra column and input the current date/time for documentation
results2[,"Date"] <- NA
results2[1,"Date"] <- format(Sys.time(), "%a %b %d %X %Y %Z")
#write results2 to a csv file and save it in my folder
write.csv(results2, file = filePath)
I obtained an API key, reproduced your problem, and then stepped through the underlying function's source code line by line.
The error is caused by the following:
data$Time[i] = as(rowXML[[dur]][1L]$value[1L]$text,
"numeric")
because the object dur contains only the following:
> dur
[1] "duration" "duration_in_traffic"
Thus rowXML[[dur]] throws the error. I'm not sure where to point the finger, but very often API's change faster than the packages built around them.
Nevertheless, you can still use the source code to get your result, as I did. It just takes a few more lines of code to clean up the results yourself:
xmlChildren(results$row[[1L]])
$status
<status>OK</status>
$duration
<duration>
<value>20185</value>
<text>5 hours 36 mins</text>
</duration>
$distance
<distance>
<value>459271</value>
<text>459 km</text>
</distance>
$duration_in_traffic
<duration_in_traffic>
<value>20957</value>
<text>5 hours 49 mins</text>
</duration_in_traffic>
attr(,"class")
[1] "XMLInternalNodeList" "XMLNodeList"
Per your request in the comment, here's a bit more about what I did to get this.
First, take the arguments from the call to this function and create objects out of them (i.e. just run each argument as an individual command to create the objects). Next, load the XML and Rcurl libraries. Also, put your API key in an object called key.
After that you just take the source code of the function and run it line by line, skipping the part where the function call is defined. Along the way there are a small number of unused arguments which you can just create and set to "".
# function (origin, destination, combinations = "all", mode, key = #get.api.key(),
# shape = "wide", avoid = "", departure = "now", dep_date = "",
# dep_time = "", traffic_model = "best_guess", arrival = "",
# arr_date = "", arr_time = "") # don't run this
if (!(mode %in% c("driving", "walking", "bicycling", "transit"))) {
stop("Mode of transportation not recognized. Mode should be one of ",
"'bicycling', 'transit', 'driving', 'walking' ")
if (!(combinations %in% c("all", "pairwise"))) {
stop("Combinations between origin and destination not recognized. Combinations should be one of ",
"'all', 'pairwise' ")
}
if (!(avoid %in% c("", "tolls", "highways", "ferries", "indoor"))) {
stop("Avoid parameters not recognized. Avoid should be one of ",
"'tolls', 'highways', 'ferries', 'indoor' ")
}
if (!(traffic_model %in% c("best_guess", "pessimistic", "optimistic"))) {
stop("Traffic model not recognized. Traffic model should be one of ",
"'best_guess', 'pessimistic', 'optimistic'")
}
seconds = "now"
seconds_arrival = ""
UTCtime = strptime("1970-01-01 00:00:00", "%Y-%m-%d %H:%M:%OS",
tz = "GMT")
min_secs = round(as.numeric(difftime(as.POSIXlt(Sys.time(),
"GMT"), UTCtime, units = "secs")))
if (dep_date != "" && dep_time != "") {
depart = strptime(paste(dep_date, dep_time), "%Y-%m-%d %H:%M:%OS",
tz = "GMT")
seconds = round(as.numeric(difftime(depart, UTCtime,
units = "secs")))
}
if (departure != "now") {
seconds = departure
}
if (departure != "now" && departure < min_secs) {
stop("The departure time has to be some time in the future!")
}
if (dep_date != "" && dep_time == "") {
stop("You should also specify a departure time in the format HH:MM:SS UTC")
}
if (dep_date == "" && dep_time != "") {
stop("You should also specify a departure date in the format YYYY-MM-DD UTC")
}
if (dep_date != "" && dep_time != "" && seconds < min_secs) {
stop("The departure time has to be some time in the future!")
}
if (arr_date != "" && arr_time != "") {
arriv = strptime(paste(arr_date, arr_time), "%Y-%m-%d %H:%M:%OS",
tz = "GMT")
seconds_arrival = round(as.numeric(difftime(arriv, UTCtime,
units = "secs")))
}
if (arrival != "") {
seconds_arrival = arrival
}
if (arrival != "" && arrival < min_secs) {
stop("The arrival time has to be some time in the future!")
}
if (arr_date != "" && arr_time == "") {
stop("You should also specify an arrival time in the format HH:MM:SS UTC")
}
if (arr_date == "" && arr_time != "") {
stop("You should also specify an arrival date in the format YYYY-MM-DD UTC")
}
if (arr_date != "" && arr_time != "" && seconds_arrival <
min_secs) {
stop("The arrival time has to be some time in the future!")
}
if ((dep_date != "" || dep_time != "" || departure != "now") &&
(arr_date != "" || arr_time != "" || arrival != "")) {
stop("Cannot input departure and arrival times. Only one can be used at a time. ")
}
if (combinations == "pairwise" && length(origin) != length(destination)) {
stop("Size of origin and destination vectors must be the same when using the option: combinations == 'pairwise'")
}
if (combinations == "all") {
data = expand.grid(or = origin, de = destination)
}
else if (combinations == "pairwise") {
data = data.frame(or = origin, de = destination)
}
n = dim(data)
n = n[1]
data$Time = NA
data$Distance = NA
data$status = "OK"
avoidmsg = ""
if (avoid != "") {
avoidmsg = paste0("&avoid=", avoid)
}
for (i in 1:1:n) {
url = paste0("maps.googleapis.com/maps/api/distancematrix/xml?origins=",
data$or[i], "&destinations=", data$de[i], "&mode=",
mode, "&sensor=", "false", "&units=metric", "&departure_time=",
seconds, "&traffic_model=", traffic_model, avoidmsg)
if (!is.null(key)) {
key = gsub(" ", "", key)
url = paste0("https://", url, "&key=", key)
}
else {
url = paste0("http://", url)
}
webpageXML = xmlParse(getURL(url))
results = xmlChildren(xmlRoot(webpageXML))
request.status = as(unlist(results$status[[1]]), "character")
if (!is.null(results$error_message)) {
stop(paste(c("Google API returned an error: ", xmlValue(results$error_message)),
sep = ""))
}
if (request.status == "REQUEST_DENIED") {
set.api.key(NULL)
data$status[i] = "REQUEST_DENIED"
}
rowXML = xmlChildren(results$row[[1L]])
Status = as(rowXML$status[1]$text, "character")
if (Status == "ZERO_RESULTS") {
data$status[i] = "ROUTE_NOT_FOUND"
}
if (Status == "NOT_FOUND") {
data$status[i] = "PLACE_NOT_FOUND"
}
if (Status == "OVER_QUERY_LIMIT") {
stop("You have exceeded your allocation of API requests for today.")
}
if (data$status[i] == "OK") {
data$Distance[i] = as(rowXML$distance[1]$value[1]$text,
"numeric")
dur = grep("duration", names(rowXML), value = TRUE)
data$Time[i] = as(rowXML[[dur]][1L]$value[1L]$text,
"numeric")
}
}
datadist = data[c("or", "de", "Distance")]
datatime = data[c("or", "de", "Time")]
datastat = data[c("or", "de", "status")]
if (n > 1) {
if (shape == "wide" && combinations == "all") {
Distance = reshape(datadist, timevar = "de", idvar = c("or"),
direction = "wide")
Time = reshape(datatime, timevar = "de", idvar = c("or"),
direction = "wide")
Stat = reshape(datastat, timevar = "de", idvar = c("or"),
direction = "wide")
}
else {
Distance = datadist
Time = datatime
Stat = datastat
}
}
else {
Distance = data$Distance[i]
Time = data$Time[i]
Stat = data$status[i]
}
output = list(Time = Time, Distance = Distance, Status = Stat)
If you're not constrained to using gmapsdistance, my googleway package will give you the same results. The only difference is currently you have to specify the departure_time.
library(googleway)
orig <- "London"
dest <- "Paris"
api_key <- "your_api_key"
result <- google_distance(origin = c(orig, dest), destination = c(orig, dest),
mode = "driving",
traffic_model = "best_guess",
departure_time = Sys.time() + 60,
key = api_key)
result$rows$elements
# [[1]]
# distance.text distance.value duration.text duration.value status
# 1 1 m 0 1 min 0 OK
# 2 459 km 459271 5 hours 36 mins 20185 OK
#
# [[2]]
# distance.text distance.value duration.text duration.value status
# 1 470 km 470366 5 hours 25 mins 19484 OK
# 2 1 m 0 1 min 0 OK

How to patch an S4 method in an R package?

If you find a bug in a package, it's usually possible to patch the problem with fixInNamespace, e.g. fixInNamespace("mean.default", "base").
For S4 methods, I'm not sure how to do it though. The method I'm looking at is in the gWidgetstcltk package. You can see the source code with
getMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"))
I can't find the methods with fixInNamespace.
fixInNamespace(".svalue", "gWidgetstcltk")
Error in get(subx, envir = ns, inherits = FALSE) :
object '.svalue' not found
I thought setMethod might do the trick, but
setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"),
definition = function (obj, toolkit, index = NULL, drop = NULL, ...)
{
widget = getWidget(obj)
sel <- unlist(strsplit(tclvalue(tcl(widget, "selection")),
" "))
if (length(sel) == 0) {
return(NA)
}
theChildren <- .allChildren(widget)
indices <- sapply(sel, function(i) match(i, theChildren))
inds <- which(visible(obj))[indices]
if (!is.null(index) && index == TRUE) {
return(inds)
}
if (missing(drop) || is.null(drop))
drop = TRUE
chosencol <- tag(obj, "chosencol")
if (drop)
return(obj[inds, chosencol, drop = drop])
else return(obj[inds, ])
},
where = "package:gWidgetstcltk"
)
Error in setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"), :
the environment "gWidgetstcltk" is locked; cannot assign methods for function ".svalue"
Any ideas?
How about the old-school way of getting the source, applying the change and rebuilding?
you can first get the generic out, and then fix the generic by setMethod in your global environment, and then assign it back to that namespace
.svalue <- gWidgetstcltk:::.svalue
setMethod(".svalue", c("gTabletcltk", "guiWidgetsToolkittcltk"),
definition = function (obj, toolkit, index = NULL, drop = NULL, ...)
{
widget = getWidget(obj)
sel <- unlist(strsplit(tclvalue(tcl(widget, "selection")),
" "))
if (length(sel) == 0) {
return(NA)
}
theChildren <- .allChildren(widget)
indices <- sapply(sel, function(i) match(i, theChildren))
inds <- which(visible(obj))[indices]
if (!is.null(index) && index == TRUE) {
return(inds)
}
if (missing(drop) || is.null(drop))
drop = TRUE
chosencol <- tag(obj, "chosencol")
if (drop)
return(obj[inds, chosencol, drop = drop])
else return(obj[inds, ])
}#,
#where = "package:gWidgetstcltk"
)
assignInNamespace(".svalue", .svalue, ns = "gWidgetstcltk")

Resources