R Code gmapsdistance - r

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

Related

Rcript Error in if (nx >= 2^31 || ny >= 2^31) stop("long vectors are not supported")

UPD: replaced merge to inner_join, new error:
Error in UseMethod("tbl_vars") :
no applicable method for 'tbl_vars' applied to an object of class "function"
Calls: inner_join ... tbl_vars -> new_sel_vars -> structure -> tbl_vars_dispatch
I am trying to run my R-script from command line, but it is return error:
Error in if (nx >= 2^31 || ny >= 2^31) stop("long vectors are not supported") :
missing value where TRUE/FALSE needed
Calls: merge -> merge.data.frame
Execution halted
What it's mean?
Where are no one problems, when I run similar code from R or Rstudio.
How can I fix this issue?
Part of R-script
clonotypes_tables = function(name, cell, mode){
sub = subset(metadata, metadata$donor == as.character(name))
sub = subset(sub, sub$cell_type == as.character(cell))
if (nrow(sub) > 1){
sub = sub[order(sub$time_point), ]
if (file.exists(paste(getwd(), sub$file_name[1], sep="/")) & file.exists(paste(getwd(), sub$file_name[2], sep="/"))){
point1 = read.table(sub$file_name[1], header = T)
#cat("check1")
point2 = read.table(sub$file_name[2], header = T)
if (nrow(point1) >= 1000 & nrow(point2) >= 1000){
#common.clonotype = merge(point1[1:1000,], point2[1:1000,], by = c("cdr3aa", "v"))
if (mode == "CDR3_V"){
common.clonotype = merge(point1, point2, by = c("cdr3aa", "v"))
common.clonotype$clon = paste(common.clonotype$cdr3aa, common.clonotype$v, sep = "~")
}
else{
common.clonotype = merge(point1, point2, by = c("cdr3aa"))
common.clonotype$clon = common.clonotype$cdr3aa
}
common.clonotype = common.clonotype[,c("clon", "freq.x", "freq.y")]
colnames(common.clonotype) = c("Clonotypes", "0.5", "1")
dim(common.clonotype)
common.clonotype = common.clonotype[order(common.clonotype[2], decreasing = T), ]
common.clonotype
}
#return(common.clonotype)
}
else{
print(paste(name, cell, "hasn't two time points", sep = " "))
}
}
}
I guess you ran your R-script from command line on larger files or different files. The built-in (base) merge function won't merge data frames with more than 2^31 rows. Check the merge.data.frame code:
...
nx <- nrow(x <- as.data.frame(x))
ny <- nrow(y <- as.data.frame(y))
if (nx >= 2^31 || ny >= 2^31)
stop("long vectors are not supported")
...
Try alternative merge functions such as ..._join in dplyr library or the most efficient data.table framework.

vapply: values must be length 11

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)
}

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())
}

Parallel request historical options chain prices / Last known price in IBrokers (R)

I am trying to create Current Options Chain (options per strike, per expiration) for a ticker.
library(IBrokers)
tws <- twsConnect()
# Lets say only Call prices
AA <- reqContractDetails(tws, twsOption(local="", right="C", symbol="AAPL"))
Native implementation with snapshot is too slow:
reqMktData(tws, AA[1:2], snapshot = TRUE)
It waits around 11 sec per contract (Current number of Contracts is 626)
Another implementation:
snapShot <- function (twsCon, eWrapper, timestamp, file, playback = 1, ...)
{
if (missing(eWrapper))
eWrapper <- eWrapper()
names(eWrapper$.Data$data) <- eWrapper$.Data$symbols
con <- twsCon[[1]]
if (inherits(twsCon, "twsPlayback")) {
sys.time <- NULL
while (TRUE) {
if (!is.null(timestamp)) {
last.time <- sys.time
sys.time <- as.POSIXct(strptime(paste(readBin(con,
character(), 2), collapse = " "), timestamp))
if (!is.null(last.time)) {
Sys.sleep((sys.time - last.time) * playback)
}
curMsg <- .Internal(readBin(con, "character",
1L, NA_integer_, TRUE, FALSE))
if (length(curMsg) < 1)
next
processMsg(curMsg, con, eWrapper, format(sys.time,
timestamp), file, ...)
}
else {
curMsg <- readBin(con, character(), 1)
if (length(curMsg) < 1)
next
processMsg(curMsg, con, eWrapper, timestamp,
file, ...)
if (curMsg == .twsIncomingMSG$REAL_TIME_BARS)
Sys.sleep(5 * playback)
}
}
}
else {
evalWithTimeout(
while (TRUE) {
socketSelect(list(con), FALSE, NULL)
curMsg <- .Internal(readBin(con, "character", 1L,
NA_integer_, TRUE, FALSE))
if (!is.null(timestamp)) {
processMsg(curMsg, con, eWrapper, format(Sys.time(),
timestamp), file, ...)
}
else {
processMsg(curMsg, con, eWrapper, timestamp,
file, ...)
}
if (!any(sapply(eWrapper$.Data$data, is.na)))
return(do.call(rbind, lapply(eWrapper$.Data$data,
as.data.frame)))
}, timeout=5, onTimeout="warning")
}
}
reqMktData(tws, AA[1:20], eventWrapper=eWrapper.data(20),CALLBACK=snapShot)
It avoids waiting ( 11 secs ).
But this doesn't work if there is no real-time data or markets are closed.
So, I want to get only the last known price even if markets are closed.
This is my pseudo-solution:
reqHistoricalData(tws, AA[[1]]$contract, whatToShow='BID', barSize = "1 min", duration = "60 S")
Is there a way to parallelize this solution so it will call for historical price of several contract?
Currently it spends around 2.3 seconds per contract, while previous solution is able to get 20-30 contracts with the same time spent.
Instead of using reqMktData(), consider using reqRealTimeBars() with a variable containing your list of contracts to do what you want without the limitations of reqHistoricalData().
Real Time Bars is a query for streaming Historical Data, the data is relayed back from the same servers that provide Historical Data.

Httr header returns invalid character '-' in numeric literal

I'm using the httr to access the API for stockfighter, a CTF style trading game.
The GET function is working without any problems, but when I try and authenticate using an API key in the headers it doesn't appear to be working. Here's my place_order function
place_order <- function(acct, exchange, stock, price, qty,
direction = c("buy", "sell"),
type = c("limit", "market", "fill-or-kill",
"immediate-or-cancel")) {
# Place a stock order
if (!exists("key")) stop("No authorisation key defined.")
direction <- match.arg(direction)
type <- match.arg(type)
bdy <- list("account" = acct, "venue" = exchange, "symbol" = stock,
"price" = price, "qty" = qty, "direction" = direction,
"orderType" = type)
rurl <- paste(burl, "/venues/", exchange, "/stocks/", stock, "/orders",
sep = "")
r <- POST(rurl, body = bdy, add_headers(`X-Starfighter-Authorization` = key))
return(content(r))
}
This is what I get in return:
$ok
[1] FALSE
$error
[1] "invalid character '-' in numeric literal"
It appears that the JSON is not escaping the dashes correctly.
This is the response I get when I post to httpbin instead of the API:
$args
named list()
$data
[1] ""
$files
named list()
$form
$form$account
[1] "RB34256134"
$form$direction
[1] "buy"
$form$orderType
[1] "limit"
$form$price
[1] "12400"
$form$qty
[1] "100"
$form$symbol
[1] "FOOBAR"
$form$venue
[1] "TESTEX"
$headers
$headers$Accept
[1] "application/json, text/xml, application/xml, */*"
$headers$`Accept-Encoding`
[1] "gzip, deflate"
$headers$`Content-Length`
[1] "751"
$headers$`Content-Type`
[1] "multipart/form-data; boundary=------------------------49a2e51c0c6926dd"
$headers$Host
[1] "httpbin.org"
$headers$`User-Agent`
[1] "libcurl/7.43.0 r-curl/0.9.4 httr/1.0.0.9000"
$headers$`X-Starfighter-Authorization`
[1] "OBFUSCATED KEY HERE"
$json
NULL
$origin
[1] "1.125.48.185"
$url
[1] "http://httpbin.org/post"
I feel like this is probably a really stupid simple error but I can't work it out.
EDIT:
Here's the python method using requests and json that works perfectly.
def sf_post(path, data, key, **kwargs):
base_url = "https://api.stockfighter.io/ob/api/"
r = requests.post("%s/%s" % (base_url, path), data = data, headers = {'X-Starfighter-Authorization': key}, **kwargs)
return(r)
def order(self, price, qty, direction, order_type):
data = dict(account = self.account, venue = self.exchange, symbol = self.symbol, price = price, qty = qty,
direction = direction, orderType = order_type)
r = sf_post("%s/orders" % self.rurl, data = json.dumps(data), key = self.key)
return r.json()
cph = Stock("CPH", "EXMBEX", account = "ACCOUNTCODEHERE", key = os.environ.get("SF_KEY"))
cph.order(5000, qty = 100, direction = "buy", order_type = "limit")
{u'direction': u'buy', u'ok': True, u'ts': u'2016-01-24T00:35:21.148877285Z', u'fills': [{u'price': 4694, u'ts': u'2016-01-24T00:35:21.148881279Z', u'qty': 100}], u'originalQty': 100, u'orderType': u'limit', u'symbol': u'CPH', u'venue': u'EXMBEX', u'account': u'SSM90915021', u'qty': 0, u'id': 754, u'totalFilled': 100, u'open': False, u'price': 5000}
I thought I was probably missing something stupid, and as #hadley pointed out in the comments I was. I needed to add encode = "json" to my POST call. For posterity here's the updated function code:
place_order <- function(acct, exchange, stock, price, qty,
direction = c("buy", "sell"),
type = c("limit", "market", "fill-or-kill",
"immediate-or-cancel")) {
if (!exists("key")) stop("No authorisation key defined.")
direction <- match.arg(direction)
type <- match.arg(type)
bdy <- list("account" = acct, "venue" = exchange, "symbol" = stock,
"price" = price, "qty" = qty, "direction" = direction,
"orderType" = type)
rurl <- paste(burl, "venues/", exchange, "/stocks/", stock, "/orders",
sep = "")
r <- POST(rurl, body = bdy,
add_headers(`X-Starfighter-Authorization` = key),
encode = "json")
return(content(r))
}

Resources