In the following pseudo-code, I don't know how to identify ?unknown?. I realize that y has the name of the symbol pointed to by asset. The objects for the symbols are stored in the environment. I need to access the object through a variable.
library(quantmod)
x<-c("IBM","GOOG","AAPL")
for (asset in x)
{
y <- getSymbols(asset, src = "yahoo",from = startDate,to = endDate,auto.assign=FALSE)
mydf <- convert ?unknown? to data frame
mydf$time <- time(?unknown?)
#process mydf
#store results in another data frame
}
#display results
I would create a new environnment where I store the variables.
library(quantmod)
x<-c("IBM","GOOG","AAPL")
e = new.env()
getSymbols(x, src = "yahoo",from = startDate,
to = endDate,auto.assign=FALSE,env=e)
Then to process variable inside the new environment you can use eapply :
mydf <- eapply(e,function(asset){
})
With auto.assign=F they are not assigned to an environment variable (that is a behavior that will be deprecated). Now you get an object of class "xts". You can just do
library(quantmod)
startDate <- as.Date("2014-01-01")
endDate <- as.Date("2014-01-10")
x<-c("IBM","AAPL")
dfall<-NULL
for (asset in x)
{
y <- getSymbols(asset, src = "yahoo",
from = startDate,to = endDate,auto.assign=FALSE)
mydf <- as.data.frame(y)
names(mydf)<-c("Open","High","Low","Close","Volume","Adjusted")
mydf$symbol <- asset
mydf$time <- time(y)
if(is.null(dfall)) {
dfall<-mydf
} else {
dfall<-rbind(dfall, mydf)
}
}
dfall
Related
I am working with objects of class ts in R.
Is there code I can use to change column names in this kind of an object?
For a data frame, I would use something like this:
Shipper_City <- rename(Shipper_City,"ShipCity_Old" = "ShipCity")
Use the 'colnames()' function
You want to use colnames(), because you're dealing with a matrix in case of a ts object:
colnames(data) <- c("ColName1", "ColName2")
Hope this helps.
Here is a function that I created that might be useful for you.
rename.ts <- function(ts, ...){
if (inherits(ts, "mts")) {
x <- list(...)
old_names <- names(x)
if (all(old_names %in% colnames(ts))) {
id_old_names <- which(old_names %in% colnames(ts))
colnames(ts)[id_old_names] <- unname(unlist(x))
} else {
stop("You must provide valid column names")
}
} else {
stop("You must provide a mts object as argument")
}
ts
}
# Example
mts <- ts(data = mtcars, start = 2013, frequency = 4)
rename.ts(mts, "mpg" = "mpg2", "cyl" = "cyl2")
I've got some code that creates an object from a formula and saves the call for future use, as so:
create_obj <- function(formula, data) {
obj <- list()
# Populate obj with whatever we're interested in
# ...
# Save call for future use
obj$call <- match.call()
obj
}
obj <- create_obj(time ~ sex, data)
If I then bootstrap data I can easily build the model on the new dataset:
data <- data[sample(1:nrow(data), replace=T), ]
new_obj <- eval(obj$call)
However, if I have the formula saved in a variable and I pass the object into a new environment this won't work:
do_stuff <- function(object, newdata) {
data <- newdata[sample(1:nrow(newdata), replace=T), ]
new_object <- eval(object$call)
}
main <- function() {
my_form <- time ~ sex
obj2 <- create_obj(my_form, data)
# obj2$call: 'create_obj(formula = my_form, data = data)'
do_stuff(obj2, data)
}
Error: object my_form not found.
How can I have it so that obj$call saves time~sex rather than myform? Otherwise I need to pass the formula itself around rather than just the object, limiting the practicality.
The above example isn't reproducible but you can see the same thing with a standard lm call.
EDIT: I've solved the problem, see the accepted answer.
I've solved it by having the constructor function modify the call by evaluating the constant argument in the local environment:
create_obj <- function(formula, data) {
obj <- list()
# Populate obj with whatever we're interested in
# ...
# Save call for future use
func_call <- match.call()
func_call$formula <- eval(formula)
# obj_call is now: create_obj(formula=time~sex, data=data)
obj$call <- func_call
obj
}
I have a dataset with different receipts, items and its value:
library(arules)
library(VennDiagram)
Data <- data.frame(
Receipt_ID = c(1,1,1,1,2,2,2,2,3,3,3,3,4,4,5,5,6,6,6),
item = c('a','b','c','k','a','b','d','k','a','k','c','q','k', 'a','b','a','a', 'b', 'c'
)
,
value = c(2,3,2,4,2,5,6,7,8,1,2,3,4,5,6,7,8,3,4
)
)
And I created a market basket, with some output like below:
rules <- data.frame(
Target = c("a","a","b"),
item1 = c("b","b","k" )
,
item2 = c("k","",""),
lift = c(1,2,3),
confidence = c(0.08,0.45,0.1)
)
)
I created a function which will take the Vector of items as input(Combination of Target, item1, item2 in vector form)
findvalue <- function (vectormb) {
keyvalue <- Data[Data$item %in% vectormb, ]
keyvaluetran <- sapply(vectormb,function(x){
ret <- unique (keyvalue$Receipt_ID[keyvalue$item==x])
})
#reducetran <- calculate.overlap(keyvaluetran)
reducetran1 <- Reduce(intersect,keyvaluetran)
totalsales <- sum (keyvalue$value[keyvalue$Receipt_ID %in% reducetran1])
return(totalsales)
}
And I comverted the Dataframe to List
createlist <- function(data){
subset <- data.frame(data$Target,data$item1,data$item2)
listdata <- apply(subset,1,
function(x){
ret<-list( x[1:ncol(subset)])
names(ret)<-as.character(x[1])
return(ret)
})
listdata <- createlist(rules)
List data converts the dataframe to vector.
My question is how can I pass the Listdata Output to the function findvalue.
I tried couple of things:
findvalue(c("a","b","k")) is giving proper value as 23.
When I tried findvalue(listdata[1]), this is not giving any value.
What mistake I did. Listdata should be sent to findvalue in a loop.
Your createlist() function has no return value - hence it returns nothing for you. Here is what I would suggest:
createlist <- function(data) {
subset <- data.frame(data$Target,data$item1,data$item2)
apply(subset,1,
function(x){
ret<-list( x[1:ncol(subset)])
names(ret)<-as.character(x[1])
return(ret)
})
}
listdata <- createlist(rules)
This will create your listdata variable properly.
Then, in order to run findvalue() on it, the way the function is currently written, you need to pass on a vector, and not a list. Thus:
> class(listdata[1])
[1] "list"
> findvalue(unlist(listdata[1]))
[1] 23
Airlines_Dataset <- function(Number_Of_Rows){
#Departure Date
day.start <- "2009/01/01"
day.end <- "2014/04/25"
Departure_Date <- function(day.start,day.end,size) { //Generates Random dates
dayseq <- seq.Date(as.Date(day.start),as.Date(day.end),by="day")
dayselect <- sample(dayseq,size,replace=TRUE)
Date <- dayselect
}
Date <- data.frame(Departure_Date(day.start,day.end,size=Number_Of_Rows))
return(Date)
#Origin
Origin_Func <- function(Number_Of_Rows,...){
Origin <- (sample(c('IND','ISP','JAN','JAX','IND','ISP',
'LAS','LAX','LBB','LIT','MAF','MCI','MCO','MDW','MHT',
'MST','MCO','OAK','OAC','OMA','OMT','ORF','PBI','PDX',
'PHL','PHX','PIT','PVD','RDU','RNO','RSW','SAN','SAT',
'SDF','SEA','SFO','SJC','SLC','SMF','SNA','STL','TPA',
'TUL','TUS','ABQ','IAD'),Number_Of_Rows, replace=TRUE))
Origin <- data.frame(Origin)
/*Given below is source code of origin*/
Origin_Exec <- system.time((sample(c('IND','ISP','JAN','JAX','IND','ISP',
'LAS','LAX','LBB','LIT','MAF','MCI','MCO','MDW','MHT',
'MST','MCO','OAK','OAC','OMA','OMT','ORF','PBI','PDX',
'PHL','PHX','PIT','PVD','RDU','RNO','RSW','SAN','SAT',
'SDF','SEA','SFO','SJC','SLC','SMF','SNA','STL','TPA',
'TUL','TUS','ABQ','IAD'),Number_Of_Rows, replace=TRUE)))
}
/*Some static origin codes that generates random strings from the list given above*/
return(Origin)
}
am calling the function as given below
Airlines_Result <- Airlines_Dataset(1000)
When I call the above functions only one function is invoked that is date and tine origin is not invoked.
Final Step is to combine the data frames
Airlines_Data <- data.frame(Origin,Date)
Anyone please help to execute the code in proper format I want origin and date to be present in single function call
I reordered your code and added some lines. You do not need to have nested functions in your case. To call a function within a function write the inner functions separately. The outer function call all other functions:
Departure_Date <- function(day.start,day.end,size)
{
dayseq <- seq.Date(as.Date(day.start),as.Date(day.end),by="day")
dayselect <- sample(dayseq,size,replace=TRUE)
Date <- dayselect
return(Date)
}
#Origin
Origin_Func <- function(Number_Of_Rows)
{
Origin <- (sample(c('IND','ISP','JAN','JAX','IND','ISP',
'LAS','LAX','LBB','LIT','MAF','MCI','MCO','MDW','MHT',
'MST','MCO','OAK','OAC','OMA','OMT','ORF','PBI','PDX',
'PHL','PHX','PIT','PVD','RDU','RNO','RSW','SAN','SAT',
'SDF','SEA','SFO','SJC','SLC','SMF','SNA','STL','TPA',
'TUL','TUS','ABQ','IAD'),Number_Of_Rows, replace=TRUE))
return(Origin)
}
Airlines_Dataset <- function(day.start ="2009/01/01", day.end = "2014/04/25", Number_Of_Rows=1000)
{
Data <- data.frame(Departure_Date(day.start,day.end,Number_Of_Rows),Origin_Func(Number_Of_Rows))
names(Data) = c("Date", "Origin")
return(Data)
}
Airlines_Result = Airlines_Dataset()
I have a series of three nested functions I am trying to run. I would like to specify the default arguments of the inner-most function as elements within a list-object that is passed fro the outer-most function. Since this is a little hard to explain I have created a reproducible example that uses the same arguments and objects as my original code. Please forgive the amount of code but I wanted to make this example as close to the original as possible.
The function CreateBirthDates is causing the issue. The four arguments are all elements within the list-object sim (e.g., sim$agents$input). I call sim to the first function, wrapper, and then again to the second function, UpdateAgentStates. Within UpdateAgentStates I would like to modify sim$agents$input using the other objects within sim (e.g., sim$agents$birth_day). Since these other arguments are always the same I would like to "hard-wire" them. But if I run the wrapper function, CreateBirthDates does not recognize sim and therefore cannot specify the default arguments.
I created alternate versions of CreateBirthDates:
CreateBirthDates_with_sim. This includes sim as an argument. Running this function with the wrapper function works!
This seems like a "this-is-the-way-R-works" issue but I don't fully understand why. I would like to improve my basic programming skills so any suggestion or comments would be most appreciated!
Thank you very much,
Javan
See code below:
# Create some example data and load the package lubridate -----
library(lubridate)
t1 <- list("agents"=list("input"=data.frame(id=seq(1:5),class=rep("Male",5),age=rep(6,5))),
"pars"=list("global"=list("input_age_period"="years",
"birth_day"="01Sep",
"sim_start"=as.POSIXct("2000-10-01"))))
# Specify the original functions -------
wrapper <- function(sim,use_sim=FALSE){
if(use_sim==FALSE){
UpdateAgentStates(agent_states = NULL,sim=sim,init=TRUE)
} else {
UpdateAgentStates_with_sim(agent_states = NULL,sim=sim,init=TRUE)
}
}
UpdateAgentStates <- function(agent_states = NULL,
sim = sim,
init = FALSE
) {
if (init == TRUE) {
input <- sim$agents$input
input <- CreateBirthDate(input)
sim$input <- input
return(sim)
}
}
UpdateAgentStates_with_sim <- function(agent_states = NULL,
sim = sim,
init = FALSE
) {
if (init == TRUE) {
input <- sim$agents$input
input <- CreateBirthDate_with_sim(input, sim=sim)
sim$input <- input
return(sim)
}
}
CreateBirthDate <-
function(input = sim$agents$input,
input_age_period = sim$pars$global$input_age_period,
birth_day = sim$pars$global$birth_day,
starting_day = sim$pars$global$sim_start
){
# Only proceed if there is no birth_date column
if(is.null(input$birth_date)){
# Loop through each row in the input
for(a in 1:nrow(input)){
# Is the age_period a year?
if(input_age_period == "year" || input_age_period == "years") {
# Determine the first sim_start date after the birth_day
one_year <- as.period(1, "year")
s0 <- as.Date(starting_day - (one_year*input$age[a]))
# Set the format of the birth_day
birth_day_format <- guess_formats(birth_day,"dm")
birth_day_format <- paste(birth_day_format,"%Y",sep="")
# Determine the first birth_day after s0
s1 <- as.Date(paste(birth_day,year(s0),sep=""), format=birth_day_format)
if(length(s1)>1){
s1 <- s1[-(which(is.na(s1)))]
}
if(s0 >= s1) {
input$birth_date[a] <- as.character(s1)
} else {
input$birth_date[a] <- as.character(s1-one_year)
}
} else {
# If age period is not a year
age_period_unit <- as.period(1, input_age_period)
input$birth_date[a] <- as.character(starting_day -
(age_period_unit*input$age[a]))
}
}
}
# Convert birth_date to a POSIXct object
# input$birth_date <- as.POSIXct(input$birth_date, tz =
# tz(sim$pars$global$sim_start))
return(input)
}
# Specify the modified functions -------
CreateBirthDate_with_sim <-
function(input = sim$agents$input,
input_age_period = sim$pars$global$input_age_period,
birth_day = sim$pars$global$birth_day,
starting_day = sim$pars$global$sim_start, sim=sim
){
# Only proceed if there is no birth_date column
if(is.null(input$birth_date)){
# Loop through each row in the input
for(a in 1:nrow(input)){
# Is the age_period a year?
if(input_age_period == "year" || input_age_period == "years") {
# Determine the first sim_start date after the birth_day
one_year <- as.period(1, "year")
s0 <- as.Date(starting_day - (one_year*input$age[a]))
# Set the format of the birth_day
birth_day_format <- guess_formats(birth_day,"dm")
birth_day_format <- paste(birth_day_format,"%Y",sep="")
# Determine the first birth_day after s0
s1 <- as.Date(paste(birth_day,year(s0),sep=""), format=birth_day_format)
if(length(s1)>1){
s1 <- s1[-(which(is.na(s1)))]
}
if(s0 >= s1) {
input$birth_date[a] <- as.character(s1)
} else {
input$birth_date[a] <- as.character(s1-one_year)
}
} else {
# If age period is not a year
age_period_unit <- as.period(1, input_age_period)
input$birth_date[a] <- as.character(starting_day -
(age_period_unit*input$age[a]))
}
}
}
# Convert birth_date to a POSIXct object
# input$birth_date <- as.POSIXct(input$birth_date, tz =
# tz(sim$pars$global$sim_start))
return(input)
}
# Try running the wrapper function -------------
# Original version, doesn't work
wrapper(t1, use_sim = FALSE)
# But if I add an argument for sim to CreateBirthDate
wrapper(t1, use_sim = TRUE)
There is a difference between using a global function within another global function, and defining a function within another function. In this first example the scope for inner_func is the global environment and sim does not exist in the global environment (the only variables that does is t1):
t1 <- 1
inner_func <- function() {
final <- sim*2
return(final)
}
outer_func <- function(sim = w){ inner_func() }
outer_func(t1)
Error in inner_func() : object 'sim' not found
However if we define the inner_func inside of outer_func then you will get the behaviour you are expecting:
t1 <- 1
outer_func <- function(sim = w){
inner_func <- function() {
final <- sim*2
return(final)
}
inner_func()
}
outer_func(t1)
[1] 2