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.
Related
I am trying to perform this MNIST example, but instead of using
input_dataset <- tf$examples$tutorials$mnist$input_data
mnist <- input_dataset$read_data_sets("MNIST-data", one_hot = TRUE)
I am trying to import the dataset locally in my Documents/MNIST/MNIST-data folder.
The first attempt, I tried from an example:
images <- file("t10k-images-idx3-ubyte", "rb")
readBin(images, integer(), n=4, endian="big")
m = matrix(readBin(images, integer(), size=1, n=28*28, endian="big"),28,28)
image(m)
par(mfrow=c(5,5))
par(mar=c(0,0,0,0)
for(i in 1:25){m = matrix(readBin(images,integer(), size=1, n=28*28, endian="big"),28,28);image(m[,28:1])}
I wasn't sure how to proceed from there, so I tried something another example I found on GitHub:
load.mnist <- function(dir) {
load.image.file <- function(filename) {
ret <- list()
f <- file(filename,'rb')
readBin(f,'integer',n=1,size=4,endian='big')
ret$n <- readBin(f,'integer',n=1,size=4,endian='big')
nrow <- readBin(f,'integer',n=1,size=4,endian='big')
ncol <- readBin(f,'integer',n=1,size=4,endian='big')
x <- readBin(f,'integer',n=ret$n*nrow*ncol,size=1,signed=F)
ret$x <- matrix(x, ncol=nrow*ncol, byrow=T)
close(f)
ret
}
load.label.file <- function(filename) {
f = file(filename,'rb')
readBin(f,'integer',n=1,size=4,endian='big')
n = readBin(f,'integer',n=1,size=4,endian='big')
y = readBin(f,'integer',n=n,size=1,signed=F)
close(f)
y
}
mnist <- list()
mnist$train <- load.image.file(paste(dir,'/train-images-idx3-ubyte',sep=""))
mnist$test <- load.image.file(paste(dir,'/t10k-images-idx3-ubyte',sep=""))
mnist$train$y <- load.label.file(paste(dir,'/train-labels-idx1-ubyte',sep=""))
n <- length(mnist$train$y)
mnist$train$yy <- matrix(rep(0,n*10),nrow=n,ncol=10)
for (i in 1:n){
mnist$train$yy[i,mnist$train$y[i] + 1] <- 1
}
mnist$test$y <- load.label.file(paste(dir,'/t10k-labels-idx1-ubyte',sep=""))
m <- length(mnist$test$y)
mnist$test$yy <- matrix(rep(0,m*10),nrow=m,ncol=10)
for (j in 1:m){
mnist$test$yy[j,mnist$test$y[j] + 1] <- 1
}
mnist
}
show.digit <- function(arr784, col=gray(12:1/12), ...) {
image(matrix(arr784, nrow=28)[,28:1], col=col, ...)
}
show_digit(train$x[5,])
Again, I wasn't sure how to proceed or how that could be implemented in the MNIST For ML Beginners example.
The third attempt I've tried was from the Iris dataset TF example:
library(tensorflow)
library(tfdatasets)
mnist_train_spec <- csv_record_spec("mnist_train.csv")
dataset <- text_line_dataset("mnist_train.csv", record_spec = mnist_train_spec)
str(dataset)
mnist_train_spec <- csv_record_spec(
names = c("label", paste("P", as.character(c(2:785)), sep = ""))
)
This last attempt throws out an error - Error in delim_record_spec(example_file, delim = ",", skip, names, types, :
You must provide an example_file if you don't explicitly specify names and types (or defaults)
My main question is, how can I locally import MNIST data files into R, and still be able to run the MNIST example without using the two lines of code I first mentioned?
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)
library(downloader)
url <- "https://raw.githubusercontent.com/genomicsclass/dagdata/master/inst/extdata/femaleControlsPopulation.csv"
filename <- "femaleControlsPopulation"
download(url, destfile=filename)
dat <- read.csv(filename)
x <- unlist( read.csv(filename))
set.seed(1)
n <- 10000
averages5 <- vector("numeric", n)
for (i in 1:n){
x <- sample(x,5)
averages5[i] <- mean(x)
}
hist(averages5)
mean(abs(averages5-mean(x))>1)
I have the problem that appear empty hist and the mean is 0.....pls i need help
This will do what you want:
url <- "https://raw.githubusercontent.com/genomicsclass/dagdata/master/inst/extdata/femaleControlsPopulation.csv"
dat <- read.table(file=url, header=TRUE)
x <- dat$Bodyweight
n <- 10000
averages5 <- replicate(n, mean(sample(x,5)))
hist(averages5)
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)