Trying to nest functions with in a function to return a list in R after taking in a data frame. But running into a problem right away getting the error:
Error in ------frqTbl <- function(df) { : object 'frqTbl' not found
Is there some way to define a variable that's a function before the function definition? Or is the nesting incorrect?
Tested with:
data(diamonds, package = "ggplot2")
test <- diamonds[1:100,]
mstrFnct(test)
mstrFnct <- function(df){
output <- list()
frqTbl <- function(df){
fctvr <- df[sapply(df,is.factor)]
logicvr <- df[sapply(df,is.logical)]
nwDf <- data.frame(fctvr,logicvr)
if(ncol(nwDf)>0){
freq <-list()
for (i in 1:ncol(nwDf)){
freq[[i]] <- as.data.frame(table((nwDf)[,i]))
names(freq[[i]])[1]=colnames(nwDf[i])
}
return(freq)
}
else{
print("There are no categorical or logical variables in the data
frame.")
}
}
output[[length(output)+1]] <- frqTbl(df)
rSqd <- function(df){
y <- df[sapply(df,is.numeric)]
if(ncol(y)>=2){
c <- combn(colnames(y), 2)
vrPrs <- paste(c[1,], c[2,], sep = "-")
m <- cor(y, method = "pearson")
r <- m[which(lower.tri(m))]
vlus <- r^2
df2 <- data.frame(vrPrs, values)
names(df2) <- sub("^VrPrs$", "Variable Pairs",
names(df2))
names(df2) <- sub("^vlus$", "R-Square", names(df2))
format.data.frame(df2)
return(df2)
}
else{
print(paste("This Data Frame does not have two or more numerical
columns to compute the Pearson correlation coefficient(s)."))
}
}
output[[length(output)+1]] <- rSqd(df)
}
Is there some way to define a variable that's a function before the
function definition?
No. (see first code chunk)
Or is the nesting incorrect?
Actually not. You just messed up the variable names. (see second code chunk)
I suggest the following code to cover your example:
frqTbl <- function(df){
fctvr <- df[sapply(df,is.factor)]
logicvr <- df[sapply(df,is.logical)]
nwDf <- data.frame(fctvr,logicvr)
if(ncol(nwDf)>0){
freq <-list()
for (i in 1:ncol(nwDf)){
freq[[i]] <- as.data.frame(table((nwDf)[,i]))
names(freq[[i]])[1]=colnames(nwDf[i])
}
return(freq)
}
else{
print("There are no categorical or logical variables in the data
frame.")
}
}
rSqd <- function(df){
y <- df[sapply(df,is.numeric)]
if(ncol(y)>=2){
c <- combn(colnames(y), 2)
vrPrs <- paste(c[1,], c[2,], sep = "-")
m <- cor(y, method = "pearson")
r <- m[which(lower.tri(m))]
vlus <- r^2
df2 <- data.frame(vrPrs, vlus)
names(df2) <- sub("^vrPrs$", "Variable Pairs",
names(df2))
names(df2) <- sub("^vlus$", "R-Square", names(df2))
format.data.frame(df2)
return(df2)
}
else{
print(paste("This Data Frame does not have two or more numerical
columns to compute the Pearson correlation coefficient(s)."))
}
}
mstrFnct <- function(df){
output <- list()
output[[length(output)+1]] <- frqTbl(df)
output[[length(output)+1]] <- rSqd(df)
return(output)
}
data(diamonds, package = "ggplot2")
test <- diamonds[1:100,]
mstrFnct(test)
But you could also pack the function definitions into the master function. Like this:
mstrFnct <- function(df){
# create output list
output <- list()
# define function frqTbl()
frqTbl <- function(df){
fctvr <- df[sapply(df,is.factor)]
logicvr <- df[sapply(df,is.logical)]
nwDf <- data.frame(fctvr,logicvr)
if(ncol(nwDf)>0){
freq <-list()
for (i in 1:ncol(nwDf)){
freq[[i]] <- as.data.frame(table((nwDf)[,i]))
names(freq[[i]])[1]=colnames(nwDf[i])
}
return(freq)
}
else{
print("There are no categorical or logical variables in the data
frame.")
}
}
# call function frqTbl() and store result in list
output[[length(output)+1]] <- frqTbl(df)
# define function rSqd()
rSqd <- function(df){
y <- df[sapply(df,is.numeric)]
if(ncol(y)>=2){
c <- combn(colnames(y), 2)
vrPrs <- paste(c[1,], c[2,], sep = "-")
m <- cor(y, method = "pearson")
r <- m[which(lower.tri(m))]
vlus <- r^2
df2 <- data.frame(vrPrs, vlus)
names(df2) <- sub("^vrPrs$", "Variable Pairs",
names(df2))
names(df2) <- sub("^vlus$", "R-Square", names(df2))
format.data.frame(df2)
return(df2)
}
else{
print(paste("This Data Frame does not have two or more numerical
columns to compute the Pearson correlation coefficient(s)."))
}
}
# call function rSqd() and store result in list
output[[length(output)+1]] <- rSqd(df)
return(output)
}
data(diamonds, package = "ggplot2")
test <- diamonds[1:100,]
mstrFnct(test)
Related
So I have a large data set that I have imported and split up. I've made sure to attach everything and tried to run a code to determine the number of breakpoints using AIC.
rm(list=ls())
library(Matching)
library(segmented)
dinosaurs=read.csv("C:/Users/user/Desktop/NEW PLOTS FOR DINOS/centrum_input_fin.csv")
attach(dinosaurs)
names(dinosaurs)
dino_names <- names(dinosaurs)
#NEED TO EXPORT FILES (EXPORT THE ALL_DATA_PLUS_SORTED OUT)
all_data_plus_sorted<-NULL
for(j in 1:length(dino_names))
{
with_gaps<-eval(parse(text = dino_names[j]))
gaps <- which(is.na(with_gaps))
non_gaps <-which(1:length(with_gaps) %in%gaps==FALSE)
sorted_without_gaps <- sort(with_gaps[!is.na(with_gaps)],decreasing=TRUE)
ordered_with_gaps<-rep(NA,length(with_gaps))
for(k in 1:length(non_gaps))
{
ordered_with_gaps[non_gaps[k]] <- sorted_without_gaps[k]
}
to_export<-cbind(with_gaps,ordered_with_gaps)
colnames(to_export)<-c(paste(dino_names[j],"_actual_with_gaps",sep=""),paste(dino_names[j],"_ordered_with_gaps",sep=""))
all_data_plus_sorted<- cbind(all_data_plus_sorted,to_export)
}
all_data_plus_sorted
attach(as.data.frame(all_data_plus_sorted))
print(dinosaurs)
detach(as.data.frame(all_data_plus_sorted))
detach(dinosaurs)
#split species
Dyoplosaurus_acutosquameus_ROM734 <- Dyoplosaurus_acutosquameus_ROM734[!is.na(Dyoplosaurus_acutosquameus_ROM734)]
Staurikosaurus_pricei <- Staurikosaurus_pricei[!is.na(Staurikosaurus_pricei)]
Opistocoelocaudia_skarzynskii <- Opistocoelocaudia_skarzynskii[!is.na(Opistocoelocaudia_skarzynskii)]
Stegosaurus_stenops._NHMUKPVR36730 <- Stegosaurus_stenops._NHMUKPVR36730[!is.na(Stegosaurus_stenops._NHMUKPVR36730)]
Giraffatitan_brancai <- Giraffatitan_brancai[!is.na(Giraffatitan_brancai)]
Camptosaurus <- Camptosaurus[!is.na(Camptosaurus)]
Camptosaurus_prestwichii <- Camptosaurus_prestwichii[!is.na(Camptosaurus_prestwichii)]
A_greppini <- A_greppini[!is.na(A_greppini)]
Astrophocaudia_slaughteri_SMU61732 <- Astrophocaudia_slaughteri_SMU61732[!is.na(Astrophocaudia_slaughteri_SMU61732)]
Tastavinsaurus_sanzi_gen_MPZ999 <- Tastavinsaurus_sanzi_gen_MPZ999[!is.na(Tastavinsaurus_sanzi_gen_MPZ999)]
MOZ_Pv1221 <- MOZ_Pv1221[!is.na(MOZ_Pv1221)]
Mamenchisaurus <- Mamenchisaurus[!is.na(Mamenchisaurus)]
Bromtosaurus_CMNo3018 <- Bromtosaurus_CMNo3018[!is.na(Bromtosaurus_CMNo3018)]
Lufengosaurus_Hueni <- Lufengosaurus_Hueni[!is.na(Lufengosaurus_Hueni)]
Mamenchisaurus_hochuanensi <- Mamenchisaurus_hochuanensi[!is.na(Mamenchisaurus_hochuanensi)]
Spinosaurus_FSACKK11888 <- Spinosaurus_FSACKK11888[!is.na(Spinosaurus_FSACKK11888)]
Buitreraptor_MPCNPV370 <- Buitreraptor_MPCNPV370[!is.na(Buitreraptor_MPCNPV370)]
Buitreraptor_MPCA245 <- Buitreraptor_MPCA245[!is.na(Buitreraptor_MPCA245)]
Huabeisaurus_allocotus_HBV20001 <- Huabeisaurus_allocotus_HBV20001[!is.na(Huabeisaurus_allocotus_HBV20001)]
Tethyshadros_insularis_SC57021 <- Tethyshadros_insularis_SC57021[!is.na(Tethyshadros_insularis_SC57021)]
Compsognathus_longipes_CNJ79 <- Compsognathus_longipes_CNJ79[!is.na(Compsognathus_longipes_CNJ79)]
Archaeopteryx12 <- Archaeopteryx12[!is.na(Archaeopteryx12)]
Sinosauropteryx_NIGP127586 <- Sinosauropteryx_NIGP127586[!is.na(Sinosauropteryx_NIGP127586)]
Sinosauropteryx_NIGP_127587 <- Sinosauropteryx_NIGP_127587[!is.na(Sinosauropteryx_NIGP_127587)]
Tetonosaurus_tilletti_AMNH3040 <- Tetonosaurus_tilletti_AMNH3040[!is.na(Tetonosaurus_tilletti_AMNH3040)]
Bambiraptor_feinbergi_FIP001 <- Bambiraptor_feinbergi_FIP001[!is.na(Bambiraptor_feinbergi_FIP001)]
Seimosaurus.halli_NMMNH3690 <- Seimosaurus.halli_NMMNH3690[!is.na(Seimosaurus.halli_NMMNH3690)]
Diluvicursor_pickeringi_NMVP221080 <- Diluvicursor_pickeringi_NMVP221080[!is.na(Diluvicursor_pickeringi_NMVP221080)]
Zhejiungosuurus_lishuiensis_ZMNHM8718 <- Zhejiungosuurus_lishuiensis_ZMNHM8718[!is.na(Zhejiungosuurus_lishuiensis_ZMNHM8718)]
Tianyulong_confuciusi_STMN.263 <- Tianyulong_confuciusi_STMN.263[!is.na(Tianyulong_confuciusi_STMN.263)]
Lusotitan_atalaiensis <- Lusotitan_atalaiensis[!is.na(Lusotitan_atalaiensis)]
Nemegtonykus_citus_MPCD100203 <- Nemegtonykus_citus_MPCD100203[!is.na(Nemegtonykus_citus_MPCD100203)]
Elaphrosaurus_bambergi_MBR4960 <- Elaphrosaurus_bambergi_MBR4960[!is.na(Elaphrosaurus_bambergi_MBR4960)]
Nomingia_gobiensis_GIN100119 <- Nomingia_gobiensis_GIN100119[!is.na(Nomingia_gobiensis_GIN100119)]
Nomingia_gobiensis_MPCD100119 <- Nomingia_gobiensis_MPCD100119[!is.na(Nomingia_gobiensis_MPCD100119)]
Chirostenotes_pergracilis <- Chirostenotes_pergracilis[!is.na(Chirostenotes_pergracilis)]
Seismosaurus_hallorum_NMMNHP3690 <- Seismosaurus_hallorum_NMMNHP3690[!is.na(Seismosaurus_hallorum_NMMNHP3690)]
Heterodontosaurus_tucki_SAMPKK1332 <- Heterodontosaurus_tucki_SAMPKK1332[!is.na(Heterodontosaurus_tucki_SAMPKK1332)]
Jianianhualong_tengi_DLXH1218 <- Jianianhualong_tengi_DLXH1218[!is.na(Jianianhualong_tengi_DLXH1218)]
Yinlong_downsi_IVPPV18685 <- Yinlong_downsi_IVPPV18685[!is.na(Yinlong_downsi_IVPPV18685)]
Neimongosaurus_yangi_LHV0001 <- Neimongosaurus_yangi_LHV0001[!is.na(Neimongosaurus_yangi_LHV0001)]
Magnapaulia_laticaudus_LACM17715 <- Magnapaulia_laticaudus_LACM17715[!is.na(Magnapaulia_laticaudus_LACM17715)]
Ouranosaurus_nigeriensis <- Ouranosaurus_nigeriensis[!is.na(Ouranosaurus_nigeriensis)]
Dreadnoughtus_schrani_MPMPV1156 <- Dreadnoughtus_schrani_MPMPV1156[!is.na(Dreadnoughtus_schrani_MPMPV1156)]
Pectodens_zhenyuensis_IVPPV18578 <- Pectodens_zhenyuensis_IVPPV18578[!is.na(Pectodens_zhenyuensis_IVPPV18578)]
Dilophosaurus_wetherilli <- Dilophosaurus_wetherilli[!is.na(Dilophosaurus_wetherilli)]
Gobihadros_mongoliensis_MPCD100746 <- Gobihadros_mongoliensis_MPCD100746[!is.na(Gobihadros_mongoliensis_MPCD100746)]
Gobihadros_mongoliensis_MPCD100755 <- Gobihadros_mongoliensis_MPCD100755[!is.na(Gobihadros_mongoliensis_MPCD100755)]
Auroraceratops_rugosus_GJ07913 <- Auroraceratops_rugosus_GJ07913[!is.na(Auroraceratops_rugosus_GJ07913)]
Patagotitan_mayorum_MPEFPV <- Patagotitan_mayorum_MPEFPV[!is.na(Patagotitan_mayorum_MPEFPV)]
Eoraptor_lunensi_PVSJ512 <- Eoraptor_lunensi_PVSJ512[!is.na(Eoraptor_lunensi_PVSJ512)]
Corythosaurus_casuarius <- Corythosaurus_casuarius[!is.na(Corythosaurus_casuarius)]
Caihong._Juji_PMoLB00175 <- Caihong._Juji_PMoLB00175[!is.na(Caihong._Juji_PMoLB00175)]
Eosinopteryx_brevipenna_YFGPT5197 <- Eosinopteryx_brevipenna_YFGPT5197[!is.na(Eosinopteryx_brevipenna_YFGPT5197)]
Rahonavis_ostromi_UA8656 <- Rahonavis_ostromi_UA8656[!is.na(Rahonavis_ostromi_UA8656)]
Changyuraptor_yangi_HGB016 <- Changyuraptor_yangi_HGB016[!is.na(Changyuraptor_yangi_HGB016)]
Herrerasaurus_ischigualastensis_PVL2566 <- Herrerasaurus_ischigualastensis_PVL2566[!is.na(Herrerasaurus_ischigualastensis_PVL2566)]
Herrerasaurus_ischigualastensis_UNSJ53 <- Herrerasaurus_ischigualastensis_UNSJ53[!is.na(Herrerasaurus_ischigualastensis_UNSJ53)]
Ischioceratops_zhuchengensis <- Ischioceratops_zhuchengensis[!is.na(Ischioceratops_zhuchengensis)]
Koreaceratops_hwaseongensis <- Koreaceratops_hwaseongensis[!is.na(Koreaceratops_hwaseongensis)]
# CHOOSE SAMPLE TO ANALYSE
#_________________________________________________________________________________________________
# choose sample
name_to_test <- "Koreaceratops_hwaseongensis"
y_val <- eval(parse(text = paste(name_to_test,"_actual_with_gaps",sep="")))
x_val<-1:length(y_val)
# USE AIC TO DECIDE HOW MANY BREAKS TO USE
#_________________________________________________________________________________________________
# extract AIC for models with 1-3 breakpoints
my_max_it=10
all_mods<-NULL
for(h in 1:4)
{
mod1<-segmented(lm(y_val~x_val),seg.Z=~x_val,psi=NA,control=seg.control(K=h,quant=TRUE,it.max=my_max_it),model=TRUE,nboot=50)
all_mods<-rbind(all_mods,c(h,extractAIC(mod1)[2]))
}
all_mods
my_K<-subset(all_mods,all_mods[,2]==min(all_mods[,2]))[1]
When i run the last section of the code i get the error Error in
crossprod(x, y) :
requires numeric/complex matrix/vector arguments
Not too sure why because I have put it in a data frame, is it because I'm importing the file incorrectly? Not sure how to fix.
I am trying to set up a function that checks the data then runs the appropriate function.
I have tried to move tbl1 and tbl2 into TBL.Fun. It won't run.
TBL.fun <- function (x,y){
if(length(y)==1) tbl1(x[,y])
else if(length(y)==2) tbl2(x[,y[1]],x[,y[2]])
else print("Only two columns of data, kiddo!")
}
tbl1 <- function(x){
tbl <- ftable(x)
ptbl<- round(prop.table(tbl)*100,2)
out <- tbl
out[] <- paste(tbl,"(",ptbl,"%)")
return(out)
}
tbl2 <- function(x,y){
tbl <- ftable(x,y)
ptbl<- round(prop.table(tbl)*100,2)
out <- tbl
out[] <- paste(tbl,"(",ptbl,"%)")
return(out)
}
I want the TBL.fun to check the data and based on that check, compute and print the correct table. After I combined the functions into
TBL.fun1 <- function (x,y=NULL){
if(is.vector(x)==T && is.null(y)==T) tbl1(x)
else tbl2(x,y)
tbl1 <- function(x){
tbl <- ftable(x)
ptbl<- round(prop.table(tbl)*100,2)
out <- tbl
out[] <- paste(tbl,"(",ptbl,"%)")
return(out)
}
tbl2 <- function(x,y){
tbl <- ftable(x,y)
ptbl<- round(prop.table(tbl)*100,2)
out <- tbl
out[] <- paste(tbl,"(",ptbl,"%)")
return(out)
}
}
After combining the functions i ran a dput() on the function with a single variable.
Gender <- c("F","F","F","M","M","M")
Race <- c("Black","White","Asian","White","Black","Black")
> sam_dat <- cbind(Gender,Race)
dput(TBL.fun1(sam_dat[,1]))
function (x, y)
{
tbl <- ftable(x, y)
ptbl <- round(prop.table(tbl) * 100, 2)
out <- tbl
out[] <- paste(tbl, "(", ptbl, "%)")
return(out)
}
> TBL.fun1(sam_dat[,1])
You dont have to include all functions in TBL.fun1, you just call them, depending on the condition.
You can also simplify the condition as is.vector and is.null already return logical values, so you dont have to test for == TRUE.
I inserted 2 print statements, so you can see that both functions are called.
TBL.fun1 <- function (x, y = NULL){
if (is.vector(x) && is.null(y)) {
print("used tbl1")
tbl1(x)
} else {
print("used tbl2")
tbl2(x, y)
}
}
Gender <- c("F","F","F","M","M","M")
Race <- c("Black","White","Asian","White","Black","Black")
sam_dat <- cbind(Gender,Race)
a = TBL.fun1(sam_dat[,1])
b = TBL.fun1(sam_dat[,2], sam_dat[,1])
I have the following code to analyze data sets:
library("Matrix")
Data <-list(c(2,3),c(3,2),c(2,2))
TheSizes=c(3,4)
n=2
dd=2
StdGrid <- function(Data,TheSizes)
{
SGrid <- list(
Values = Data,
Sizes = TheSizes
)
class(SGrid) <- append(class(SGrid), c("StdGrid","Moment"))
return(SGrid)
}
theObject=StdGrid
MHistogramC <- function(theObject,n,dd)
{
sizes <- theObject$Sizes
l <- length(sizes)
data <- theObject$Values
Xarray <- matrix(rep(0,l*n),ncol=n)
N <- matrix(rep(0,l*n),ncol=n)
Histo <- matrix(rep(0,l*n),ncol=n)
GrandX <- lapply(data,function(x) log(x))
minX <- rep(0,l)
maxX <- rep(0,l)
DeltaX <- rep(0,l)
for(i in 1:l){
minX[i] <- min(GrandX[[i]])
maxX[i] <- max(GrandX[[i]])
DeltaX[i] <- maxX[i]/n-minX[i]/n
}
nzero <- numeric()
for(j in 1:n){
for(i in 1:l){
Xarray[i,j] <- minX[i]+(j-1/2)*DeltaX[i]
N[i,j] <- length(which((GrandX[[i]] >= minX[i]+(j-1/2)*DeltaX[i]-DeltaX[i]) & (GrandX[[i]] <= minX[i]+(j-1/2)*DeltaX[i]+DeltaX[i])))
Histo[i,j] <- log(N[i,j])
}
if(min(Histo[,j]) > - 10000){
nzero <- c(nzero,j)
}
}
alpha <- rep(0,lnzero)
falpha <- rep(0,lnzero)
for(j in 1:length(nzero)){
fit <- lm(Xarray[,nzero[j]] ~ log(sizes/dd))
alpha[j] <- fit$coefficients[[2]]
fit2 <- lm(Histo[,nzero[j]] ~ log(sizes/dd))
falpha[j] <- -fit2$coefficients[[2]]
}
Result <- data.frame(alpha=alpha,falpha=falpha)
return(Result)
}
MHistogramU <- function(theObject,n,dd)
{
sizes <- theObject$Sizes
l <- length(sizes)
data <- theObject$Values
Xarray <- matrix(rep(0,l*n),ncol=n)
N <- matrix(rep(0,l*n),ncol=n)
Histo <- matrix(rep(0,l*n),ncol=n)
GrandX <- lapply(data,function(x) log(x))
minX <- rep(0,l)
maxX <- rep(0,l)
DeltaX <- rep(0,l)
for(i in 1:l){
minX[i] <- min(GrandX[[i]])
maxX[i] <- max(GrandX[[i]])
DeltaX[i] <- maxX[i]/n-minX[i]/n
}
nzero <- numeric()
for(j in 1:n){
for(i in 1:l){
Xarray[i,j] <- minX[i]+(j-1/2)*DeltaX[i]
N[i,j] <- length(which((GrandX[[i]] >= minX[i]+(j-1/2)*DeltaX[i]-sqrt(DeltaX[i])) & (GrandX[[i]] <= minX[i]+(j-1/2)*DeltaX[i]+sqrt(DeltaX[i]))))
Histo[i,j] <- log(N[i,j])
}
if(min(Histo[,j]) > - 10000){
nzero <- c(nzero,j)
}
}
alpha <- rep(0,lnzero)
falpha <- rep(0,lnzero)
for(j in 1:length(nzero)){
fit <- lm(Xarray[,nzero[j]] ~ log(sizes/dd))
alpha[j] <- fit$coefficients[[2]]
fit2 <- lm(Histo[,nzero[j]] ~ log(sizes/dd))
falpha[j] <- -fit2$coefficients[[2]]
}
Result <- data.frame(alpha=alpha,falpha=falpha)
return(Result)
}
Which compiles, but i don't get anything in return. If I try to print "Result" the console says that the object "Result" was not found.
The inputs are:
Data : is a list of vector/grids
TheSizes : is a vector
theObject : the data defined as the class 'StdGrid' (defined below);
n : the number of values of alpha to be calculated;
dd : the dimension of the physical support of the measure.
What can I do to see the data frame that the code is supposed to return?
That is because your code is just a bunch of functions which are not called at all. A function would return value only when the function is called, it won't call itself.
Now looking at your code, It's hard to deduce what you are trying to calculate/analyze, but assuming all other codes are correct, and all functions are coded perfectly, you need to add the following lines to view the result at the end of your code:
var_MHistogramU <- MHistogramU(theObject,n,dd)
var_MHistogramC <- MHistogramC(theObject,n,dd)
To view the result, simply print the variables.
print(var_MHistogramU)
print(var_MHistogramC)
Remember: Printing Result won't work as the variable result is a local variable for the function, which is inaccessible globally.
in the code below I am grabbing data for three symbols, then I want to apply a simple function(which is a trading strategy) to this data. Ideally, I would then run statistics on those returns, such as those native to PerformanceAnalytics.
library("quantmod")
library("PerformanceAnalytics")
options(scipen=999)
PriceData <- new.env()
Symbols <- c("SPY", "QQQ", "IWM")
StartDt <- as.Date("2015-01-01")
suppressWarnings(getSymbols(Symbols, src="yahoo", env=PriceData, from=StartDt))
x <- list()
for (i in 1:length(Symbols)) {
x[[i]] <- get(Symbols[i], pos=PriceData)
}
SYSTEM <- function(data){
ret<- Delt(Cl(x[[i]]),Op(x[[i]]),type = 'arithmetic')
mavga <- SMA(Cl(x[[i]]), n=10)
mavgb <- SMA(Cl(x[[i]]), n=20)
sig <- ifelse(mavga>mavgb,1,0)+ifelse(mavgb>mavga,-1,0)
sig <- lag(sig,1)
sig[is.na(sig)]=0
strategyreturn <- sig * ret
return(strategyreturn)
}
######I'm doing something wrong here######
y <- lappy(x,SYSTEM)
z <- do.call("cbind", y)
PerformanceTable <- function(returns){
scalar <- 252
CS <- t(Return.cumulative(returns, geometric = FALSE))
SR <- t(SharpeRatio.annualized(returns, scale=scalar, geometric = FALSE))
SOR <- t(SortinoRatio(returns))
MDD <- t(maxDrawdown(returns))
WP <- colSums(returns > 0)/colSums(returns != 0)
WP <- as.data.frame(WP)
ASD = t(sd.annualized(returns, scale=scalar))
Stat <- cbind(CS,SR,SOR,MDD,ASD,WP)
colnames(Stat) <- c("Profit","SharpeRatio", "Sortino","MaxDrawdown", "AnnStdDev", "WinPct")
print("Performance Table")
print(Stat)
return (Stat)
}
Perf <- PerformanceTable(y)
You are almost there, just replace x[[i]] by data in your function:
SYSTEM <- function(data){
ret<- Delt(Cl(data),Op(data),type = 'arithmetic')
mavga <- SMA(Cl(data), n=10)
mavgb <- SMA(Cl(data), n=20)
sig <- ifelse(mavga>mavgb,1,0)+ifelse(mavgb>mavga,-1,0)
sig <- lag(sig,1)
sig[is.na(sig)]=0
strategyreturn <- sig * ret
return(strategyreturn)
}
and add a l to lappy()
y <- lapply(x,SYSTEM)
z <- do.call("cbind", y)
I cannot really get my head around this problem:
I have a function that returns a data frame. However, the data frame is only printed in my console although I would like to have it stored in the work space. How can I achieve this?
Sample data:
n <- 32640
t <- seq(3*pi,n)
data_sim <- 30+ 2*sin(3*t)+rnorm(n)*10
data_sim <- floor(data_sim)
Function:
compress <- function (name, SR){
## -------------------------------------------------------
## COMPRESSION
library(zoo)
data <- get(name)
if (is.data.frame(data)==F){
data = as.data.frame(data)
}
SR <- SR
acrossmin <- 60
a <- nrow(data)
m <- acrossmin*SR*60
data_compress <- matrix(NA, nrow = a/m)
no_mov_subset <- matrix(NA, nrow = m)
for (i in 1:(a/m)){
subset <- data[(((i-1)*m)+1):((i*m)),]
b <- length(subset)
for (k in 1:b){
r <- subset[k]
if (r == 0){
no_mov_subset[k] <- 0
} else {
no_mov_subset[k] <- 1
}
sum_no_mov_subset <- sum(no_mov_subset)
data_compress[i] <- sum_no_mov_subset
}
colnames(data_compress) <- c("activity_count")
return(data_compress)
}
Run the code:
compress("data_sim", 4/60)
Obviously, the function returns something, but I would like it to be stored in the workspace rather than returned!
Instead of the return command you can use
data_compress <<- data_compress
This way, the data frame is stored in the workspace. So your function looks like this:
compress <- function (name, SR){
## -------------------------------------------------------
## COMPRESSION
library(zoo)
data <- get(name)
if (is.data.frame(data)==F){
data = as.data.frame(data)
}
SR <- SR
acrossmin <- 60
a <- nrow(data)
m <- acrossmin*SR*60
data_compress <- matrix(NA, nrow = a/m)
no_mov_subset <- matrix(NA, nrow = m)
for (i in 1:(a/m)){
subset <- data[(((i-1)*m)+1):((i*m)),]
b <- length(subset)
for (k in 1:b){
r <- subset[k]
if (r == 0){
no_mov_subset[k] <- 0
} else {
no_mov_subset[k] <- 1
}
sum_no_mov_subset <- sum(no_mov_subset)
data_compress[i] <- sum_no_mov_subset
}
colnames(data_compress) <- c("activity_count")
data_compress <<- data_compress
}
}
Edit: As commented by Heroka and hrbrmstr, this solution is not safe. It is better to assign the output of the function call to a variable:
data_compr <- compress("data_sim", 4/60)