diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..5b6a065 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +.Rproj.user +.Rhistory +.RData +.Ruserdata diff --git a/boots.lmer.Rcheck/00_pkg_src/boots.lmer/DESCRIPTION b/boots.lmer.Rcheck/00_pkg_src/boots.lmer/DESCRIPTION index 2117ed6..712e167 100644 --- a/boots.lmer.Rcheck/00_pkg_src/boots.lmer/DESCRIPTION +++ b/boots.lmer.Rcheck/00_pkg_src/boots.lmer/DESCRIPTION @@ -12,8 +12,8 @@ Roxygen: list(markdown = TRUE) RoxygenNote: 7.2.3 Suggests: knitr, rmarkdown VignetteBuilder: knitr -Imports: data.table +Depends: data.table, lme4, rlang, parallel, stringr NeedsCompilation: no -Packaged: 2023-03-14 21:35:01 UTC; u1317537 +Packaged: 2023-03-14 22:14:56 UTC; u1317537 Author: Hyejung Lee [aut, cre] () Maintainer: Hyejung Lee diff --git a/boots.lmer.Rcheck/00_pkg_src/boots.lmer/NAMESPACE b/boots.lmer.Rcheck/00_pkg_src/boots.lmer/NAMESPACE index f2a981d..7a32f8a 100644 --- a/boots.lmer.Rcheck/00_pkg_src/boots.lmer/NAMESPACE +++ b/boots.lmer.Rcheck/00_pkg_src/boots.lmer/NAMESPACE @@ -2,4 +2,3 @@ export(boots.lmer) export(boots.samples) -import(data.table) diff --git a/boots.lmer.Rcheck/00_pkg_src/boots.lmer/R/boots.samples.R b/boots.lmer.Rcheck/00_pkg_src/boots.lmer/R/boots.samples.R index 1a9ed33..28ce990 100644 --- a/boots.lmer.Rcheck/00_pkg_src/boots.lmer/R/boots.samples.R +++ b/boots.lmer.Rcheck/00_pkg_src/boots.lmer/R/boots.samples.R @@ -14,7 +14,6 @@ #' "subjects"=example.subject) #' output<-boots.samples(dat=example.dat,sub.id = "subjects",B=4) #create 4 bootstrap samples #' output[[1]] #This is the first one! -#' @import data.table #' @export boots.samples<-function(dat, sub.id,B){ @@ -49,8 +48,10 @@ boots.samples<-function(dat, sub.id,B){ #bind the index and no.repeat.id. as rows temp.dat<-do.call(rbind, lapply(temp, data.table::data.table)) complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) - complete.dat[,no.repeat.sub.id:=(temp.dat$no.repeat.id)] # add the new subject ID column, with no repetition - } + # complete.dat[,no.repeat.sub.id:=(temp.dat$no.repeat.id)] # add the new subject ID column, with no repetition + complete.dat[,"no.repeat.sub.id"]<-temp.dat$no.repeat.id + return(complete.dat) + } ) output diff --git a/boots.lmer.Rcheck/00_pkg_src/boots.lmer/inst/doc/create_bootstrap_samples.html b/boots.lmer.Rcheck/00_pkg_src/boots.lmer/inst/doc/create_bootstrap_samples.html index 3cb9040..a342f24 100644 --- a/boots.lmer.Rcheck/00_pkg_src/boots.lmer/inst/doc/create_bootstrap_samples.html +++ b/boots.lmer.Rcheck/00_pkg_src/boots.lmer/inst/doc/create_bootstrap_samples.html @@ -149,7 +149,18 @@

create_bootstrap_samples

-
library(boots.lmer)
+
library(boots.lmer)
+#> Loading required package: data.table
+#> Loading required package: lme4
+#> Loading required package: Matrix
+#> Loading required package: rlang
+#> 
+#> Attaching package: 'rlang'
+#> The following object is masked from 'package:data.table':
+#> 
+#>     :=
+#> Loading required package: parallel
+#> Loading required package: stringr

This vignette contains a walk-through of boots.lmer::boots.samples function.

The boots.samples function produces a list of bootstrap samples, made especially for longitudinal data. Longitudinal data formatted where multiple observations should be chosen cautiously when sampling for boostrap:

    diff --git a/boots.lmer/.Rhistory b/boots.lmer/.Rhistory index 07d856a..6e3d628 100644 --- a/boots.lmer/.Rhistory +++ b/boots.lmer/.Rhistory @@ -1,219 +1,3 @@ -temp.dat<-do.call(rbind, lapply(temp, data.frame)) -class(temp.dat) -head(temp.dat) -#bind the index and no.repeat.id. as rows -temp.dat<-do.call(rbind, lapply(temp, data.table)) -#bind the index and no.repeat.id. as rows -temp.dat<-do.call(rbind, lapply(temp, data.table::data.table)) -class(temp.dat) -head(temp.dat) -temp.dat -dat[temp.dat$index,] -class(dat[temp.dat$index,]) -temp.dat -complete.dat<-dat[temp.dat$index,] -complete.dat -complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) -complete.dat -sub.id = "subjects" -complete.dat[,sub.id] -complete.dat[,c(sub.id)]<-temp.dat$no -complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) -complete.dat[,c(sub.id)] -complete.dat -complete.dat[,"subjects"] -enquote(sub.id) -complete.dat$sub.id -complete.dat[,sub.id] -eval(sub.id) -complete.dat[,eval(sub.id)] -complete.dat[,eval(quote(sub.id))] -sub.id<-dat[,sub.id] -sub.id -sub.id = "subjects" -complete.dat[,get(sub.id)] -complete.dat[,get(sub.id)]<-temp.dat$no.repeat.id -complete.dat -complete.dat[,get(sub.id)] -temp.dat$no.repeat.id -length(temp.dat$no.repeat.id) -length(complete.dat[,get(sub.id)]) -complete.dat[,get(sub.id)]<-temp.dat$no.repeat.id -complete.dat$get(sub.id) -complete.dat[,get(sub.id) = temp.dat$no.repeat.id] -complete.dat[,get(sub.id) := temp.dat$no.repeat.id] -complete.dat[,get(sub.id) := as.list(temp.dat$no.repeat.id)] -complete.dat -complete.dat[,..sub.id] -complete.dat[,..sub.id]<-temp.dat$no.repeat.id) -complete.dat[,..sub.id]<-temp.dat$no.repeat.id -complete.dat[,..sub.id:=NULL] -complete.dat[,..sub.id] -complete.dat[,!..sub.id] -complete.dat[,(..sub.id_:=NULL] -complete.dat[,no.repeat.idtemp.dat$no.repeat.id -if(is.list(temp)){ -do.call(rbind, lapply(temp, data.frame)) -}else{#If length(sub.id)==length(unique.id), temp will be a matrix of ncol=length(unique.id). Transpose it so that the columns are index and no.repeat.id. -temp<-t(temp) -colnames(temp)<-c("index","no.repeat.id") -data.frame(temp) -} -} -) -tt<-boots.samples(sub.id = example.dat$subjects,B=4) #create 4 bootstrap samples -tt #This is a list of length B=4, each list containing the bootstrap sample data frame. $index contains index of the subject from the original vector, example.subject. $no.repeat.id contains the names of the bootstrap samples, with trailing '__#' if they were sampled more than once. -example.dat[tt[[1]]$index,]#1st bootstrap sample -cbind(example.dat[tt[[1]]$index,],"no.repeat.sample"=tt[[1]]$no.repeat.id)#1st bootstrap sample -lmer.out<-boots.lmer(y=example.dat$Y, X=example.dat[,2:4], boots.samples.list = tt) -complete.dat[,(..sub.id):=NULL] -complete.dat[,no.repeat.id:=temp.dat$no.repeat.id] -complete.dat -complete.dat<-complete.dat[,!..sub.id] -complete.dat -complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) -complete.dat<-complete.dat[,!..sub.id] -complete.dat[,no.repeat.sub.id:=temp.dat$no.repeat.id] -complete.dat -#' @examples -#' example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") -#' example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), -#' "X1"=rpois(n=length(example.subject), lambda = 3), -#' "X2"=rnorm(n=length(example.subject)), -#' "X3"=rbeta(n=length(example.subject), shape1 = 3, shape2 = 0.5), -#' "subjects"=example.subject) -#' output<-boots.samples(sub.id = example.dat$subjects,B=4) #create 4 bootstrap samples -#' output[[1]] #This is the first one! -#' @export -boots.samples<-function(dat, sub.id,B){ -sub.id<-dat[,sub.id] -#collect unique subject ID's -unique.id<-unique(sub.id) -#sample unique subject ID, B number of times -this.index<-sapply(1:B,function(e){sample(unique.id, size = length(unique.id),replace = TRUE)}) -#we need to take a note of people who are sampled more than once to make sure that they are sampled from the data as if they are different individuals. -no.repeat.id<- -apply(this.index,2, function(x){ -temp<-table(x) -for(i in seq_along(temp)){ -if(temp[i]>1){ #if the subject id appears more than once -num.appearance<-temp[i] #number of times the subject appears in the sample -x[which(x==names(temp)[i])]<-paste0(names(temp)[i],"__",1:num.appearance) #generate new subject ID by concatenating "_#" at the end of the id. Replace the old name with this -} -} -x #return the list of sampled subject ID , now all sample should be unique subject ID. -}) -#now sample the index of subject ID. -# output<- -# apply(no.repeat.id,2,function(x){ -# temp<- -# sapply(x,function(x_i){ #for each subject -# index<-which(sub.id==stringr::word(x_i,1,sep = "\\__")) #index of original data where the subject id appears -# cbind(index, "no.repeat.id"=rep(x_i,length(index)))}) -# -# #If length(sub.id)!=length(unique.id), then temp is a list of length(unique.id). Each list is for each unique id. rbind those list. -# if(is.list(temp)){ -# do.call(rbind, lapply(temp, data.frame)) -# }else{#If length(sub.id)==length(unique.id), temp will be a matrix of ncol=length(unique.id). Transpose it so that the columns are index and no.repeat.id. -# temp<-t(temp) -# colnames(temp)<-c("index","no.repeat.id") -# data.frame(temp) -# } -# -# } -# ) -output<- -apply(no.repeat.id,2,function(x){ -temp<- -sapply(x,function(x_i){ #for each subject -index<-which(sub.id==stringr::word(x_i,1,sep = "\\__")) #index of original data where the subject id appears -cbind(index, "no.repeat.id"=rep(x_i,length(index)))}) -#bind the index and no.repeat.id. as rows -temp.dat<-do.call(rbind, lapply(temp, data.table::data.table)) -complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) -# complete.dat<-complete.dat[,!..sub.id] #remove the original subject ID -complete.dat[,no.repeat.sub.id:=temp.dat$no.repeat.id] # add the new subject ID column, with no repetition -} -) -output -} -example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") -example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), -"X1"=rpois(n=length(example.subject), lambda = 3), -"X2"=rnorm(n=length(example.subject)), -"X3"=rbeta(n=length(example.subject), shape1 = 3, shape2 = 0.5), -"subjects"=example.subject) -tt<-boots.samples(dat = example.dat, sub.id = "subjects",B=4) -tt -tester<-function(y,X,no.repeat.id){#a function that fits one LMER -model_formula1<-formula(paste0("`",rlang::quo_name(y),"`", "~", "`",rlang::quo_name(X),"` +","`",rlang::quo_name(no.repeat.id),"`")) -} -tester<-function(y,X){#a function that fits one LMER -model_formula1<-formula(paste0("`",rlang::quo_name(y),"`", "~", "`",rlang::quo_name(X),"` +no.repeat.id")) -} -tester(y="Y",X=c("X1","X2","X3")) -tester<-function(y,X){#a function that fits one LMER -model_formula1<-formula(paste0("`",rlang::quo_name(y),"`", "~", "`",rlang::quo_name(X),"` +no.repeat.id")) -model_formula1 -} -tester(y="Y",X=c("X1","X2","X3")) -tester<-function(y,X){#a function that fits one LMER -# model_formula1<-formula(paste0("`",rlang::quo_name(y),"`", "~", "`",rlang::quo_name(X),"` +no.repeat.id")) -model_formula1<-formula(paste0("`",rlang::quo_name(y),"`", "~", "`",rlang::quo_name(X),"` +no.repeat.id")) -print(model_formula1) -} -tester(y="Y",X=c("X1","X2","X3")) -X=c("X1","X2","X3") -#Make sure we use backtick quotes in case the names have spaces and special characters -X.names<-lapply(X, as.name) -X -X.names -paste(X.names, collapse=" + ")) -paste(X.names, collapse=" + ") -X<-c("X1","X2","X3","this test!") -#Make sure we use backtick quotes in case the names have spaces and special characters -X.names<-lapply(X, as.name) -paste(X.names, collapse=" + ") -X.names<-paste(X.names, collapse=" + ") -formula(paste0("`",rlang::quo_name(y),"`", "~", rlang::quo_name(X.names),"+no.repeat.id")) -y="Y" -formula(paste0("`",rlang::quo_name(y),"`", "~", rlang::quo_name(X.names),"+no.repeat.id")) -X=c("X1") -#Make sure we use backtick quotes in case the names have spaces and special characters -X.names<-lapply(X, as.name) -X.names -tester<-function(y,X){#a function that fits one LMER -#Make sure we use backtick quotes in case the names have spaces and special characters -X.names<-lapply(X, as.name) -#If we have more than one covariate, concatenate them with + -if(length(X)>1){ -X.names<-paste(X.names, collapse=" + ") -X.formula<-as.formula(paste0("~ ", paste(X.names, collapse=" + "))) -} -# model_formula1<-formula(paste0("`",rlang::quo_name(y),"`", "~", "`",rlang::quo_name(X),"` +no.repeat.id")) -model_formula1<-formula(paste0("`",rlang::quo_name(y),"`", "~", rlang::quo_name(X.names),"+(1|no.repeat.id)")) -print(model_formula1) -} -tester(y="Y",X=c("X1","X2","X3")) -tester<-function(y,X,dat){#a function that fits one LMER -#Make sure we use backtick quotes in case the names have spaces and special characters -X.names<-lapply(X, as.name) -#If we have more than one covariate, concatenate them with + -if(length(X)>1){ -X.names<-paste(X.names, collapse=" + ") -X.formula<-as.formula(paste0("~ ", paste(X.names, collapse=" + "))) -} -# model_formula1<-formula(paste0("`",rlang::quo_name(y),"`", "~", "`",rlang::quo_name(X),"` +no.repeat.id")) -model_formula1<-formula(paste0("`",rlang::quo_name(y),"`", "~", rlang::quo_name(X.names),"+(1|no.repeat.id)")) -return(lme4::lmer(model_formula1,data=dat, REML=FALSE)) -} -tester(y="Y",X=c("X1","X2","X3")) -tester(y="Y",X=c("X1","X2","X3"),dat) -tester(y="Y",X=c("X1","X2","X3"),boots.samples.list[[1]]) -boots.lmer<-function(y,X,tt[[1]]){ -lmer.fit<-function(y,X,no.repeat.id, index){#a function that fits one LMER -model_formula1<-formula(paste0("`",rlang::quo_name(y),"`", "~", "`",rlang::quo_name(X),"` +","`",rlang::quo_name(no.repeat.id),"`")) -index<-as.numeric(index) y<-y[index] X<-as.matrix(X[index,]) fit<-lme4::lmer(y~X+(1|no.repeat.id), REML=FALSE) @@ -510,3 +294,219 @@ complete.dat[,no.repeat.sub.id=(temp.dat$no.repeat.id)] # add the new subject ID ) output } +library(boots.lmer) +#' @examples +#' example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") +#' example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), +#' "X1"=rpois(n=length(example.subject), lambda = 3), +#' "X2"=rnorm(n=length(example.subject)), +#' "X3"=rbeta(n=length(example.subject), shape1 = 3, shape2 = 0.5), +#' "subjects"=example.subject) +#' output<-boots.samples(dat=example.dat,sub.id = "subjects",B=4) #create 4 bootstrap samples +#' output[[1]] #This is the first one! +#' @export +boots.samples<-function(dat, sub.id,B){ +library(data.table) +sub.id<-dat[,sub.id] +#collect unique subject ID's +unique.id<-unique(sub.id) +#sample unique subject ID, B number of times +this.index<-sapply(1:B,function(e){sample(unique.id, size = length(unique.id),replace = TRUE)}) +#we need to take a note of people who are sampled more than once to make sure that they are sampled from the data as if they are different individuals. +no.repeat.id<- +apply(this.index,2, function(x){ +temp<-table(x) +for(i in seq_along(temp)){ +if(temp[i]>1){ #if the subject id appears more than once +num.appearance<-temp[i] #number of times the subject appears in the sample +x[which(x==names(temp)[i])]<-paste0(names(temp)[i],"__",1:num.appearance) #generate new subject ID by concatenating "_#" at the end of the id. Replace the old name with this +} +} +x #return the list of sampled subject ID , now all sample should be unique subject ID. +}) +output<- +apply(no.repeat.id,2,function(x){ +temp<- +sapply(x,function(x_i){ #for each subject +index<-which(sub.id==stringr::word(x_i,1,sep = "\\__")) #index of original data where the subject id appears +cbind(index, "no.repeat.id"=rep(x_i,length(index)))}) #get all observation for this particular subject. +#bind the index and no.repeat.id. as rows +temp.dat<-do.call(rbind, lapply(temp, data.table::data.table)) +complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) +complete.dat[,no.repeat.sub.id=(temp.dat$no.repeat.id)] # add the new subject ID column, with no repetition +} +) +output +} +example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") +example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), +"X1"=rpois(n=length(example.subject), lambda = 3), +"X2"=rnorm(n=length(example.subject)), +"X3"=rbeta(n=length(example.subject), shape1 = 3, shape2 = 0.5), +"subjects"=example.subject) +tt<-boots.samples(dat = example.dat, sub.id = "subjects",B=4) +tt<-boots.samples(dat = example.dat, sub.id = "subjects",B=4) +#' @examples +#' example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") +#' example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), +#' "X1"=rpois(n=length(example.subject), lambda = 3), +#' "X2"=rnorm(n=length(example.subject)), +#' "X3"=rbeta(n=length(example.subject), shape1 = 3, shape2 = 0.5), +#' "subjects"=example.subject) +#' output<-boots.samples(dat=example.dat,sub.id = "subjects",B=4) #create 4 bootstrap samples +#' output[[1]] #This is the first one! +#' @export +boots.samples<-function(dat, sub.id,B){ +library(data.table) +sub.id<-dat[,sub.id] +#collect unique subject ID's +unique.id<-unique(sub.id) +#sample unique subject ID, B number of times +this.index<-sapply(1:B,function(e){sample(unique.id, size = length(unique.id),replace = TRUE)}) +#we need to take a note of people who are sampled more than once to make sure that they are sampled from the data as if they are different individuals. +no.repeat.id<- +apply(this.index,2, function(x){ +temp<-table(x) +for(i in seq_along(temp)){ +if(temp[i]>1){ #if the subject id appears more than once +num.appearance<-temp[i] #number of times the subject appears in the sample +x[which(x==names(temp)[i])]<-paste0(names(temp)[i],"__",1:num.appearance) #generate new subject ID by concatenating "_#" at the end of the id. Replace the old name with this +} +} +x #return the list of sampled subject ID , now all sample should be unique subject ID. +}) +output<- +apply(no.repeat.id,2,function(x){ +temp<- +sapply(x,function(x_i){ #for each subject +index<-which(sub.id==stringr::word(x_i,1,sep = "\\__")) #index of original data where the subject id appears +cbind(index, "no.repeat.id"=rep(x_i,length(index)))}) #get all observation for this particular subject. +#bind the index and no.repeat.id. as rows +temp.dat<-do.call(rbind, lapply(temp, data.table::data.table)) +complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) +complete.dat[,no.repeat.sub.id:=(temp.dat$no.repeat.id)] # add the new subject ID column, with no repetition +} +) +output +} +#' @examples +#' example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") +#' example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), +#' "X1"=rpois(n=length(example.subject), lambda = 3), +#' "X2"=rnorm(n=length(example.subject)), +#' "X3"=rbeta(n=length(example.subject), shape1 = 3, shape2 = 0.5), +#' "subjects"=example.subject) +#' output<-boots.samples(dat=example.dat,sub.id = "subjects",B=4) #create 4 bootstrap samples +#' output[[1]] #This is the first one! +#' @export +boots.samples<-function(dat, sub.id,B){ +sub.id<-dat[,sub.id] +#collect unique subject ID's +unique.id<-unique(sub.id) +#sample unique subject ID, B number of times +this.index<-sapply(1:B,function(e){sample(unique.id, size = length(unique.id),replace = TRUE)}) +#we need to take a note of people who are sampled more than once to make sure that they are sampled from the data as if they are different individuals. +no.repeat.id<- +apply(this.index,2, function(x){ +temp<-table(x) +for(i in seq_along(temp)){ +if(temp[i]>1){ #if the subject id appears more than once +num.appearance<-temp[i] #number of times the subject appears in the sample +x[which(x==names(temp)[i])]<-paste0(names(temp)[i],"__",1:num.appearance) #generate new subject ID by concatenating "_#" at the end of the id. Replace the old name with this +} +} +x #return the list of sampled subject ID , now all sample should be unique subject ID. +}) +output<- +apply(no.repeat.id,2,function(x){ +temp<- +sapply(x,function(x_i){ #for each subject +index<-which(sub.id==stringr::word(x_i,1,sep = "\\__")) #index of original data where the subject id appears +cbind(index, "no.repeat.id"=rep(x_i,length(index)))}) #get all observation for this particular subject. +#bind the index and no.repeat.id. as rows +temp.dat<-do.call(rbind, lapply(temp, data.table::data.table)) +complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) +complete.dat[,no.repeat.sub.id:=(temp.dat$no.repeat.id)] # add the new subject ID column, with no repetition +} +) +output +} +tt<-boots.samples(dat = example.dat, sub.id = "subjects",B=4) +tt +#' @examples +#' example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") +#' example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), +#' "X1"=rpois(n=length(example.subject), lambda = 3), +#' "X2"=rnorm(n=length(example.subject)), +#' "X3"=rbeta(n=length(example.subject), shape1 = 3, shape2 = 0.5), +#' "subjects"=example.subject) +#' output<-boots.samples(dat=example.dat,sub.id = "subjects",B=4) #create 4 bootstrap samples +#' output[[1]] #This is the first one! +#' @export +boots.samples<-function(dat, sub.id,B){ +sub.id<-dat[,sub.id] +#collect unique subject ID's +unique.id<-unique(sub.id) +#sample unique subject ID, B number of times +this.index<-sapply(1:B,function(e){sample(unique.id, size = length(unique.id),replace = TRUE)}) +#we need to take a note of people who are sampled more than once to make sure that they are sampled from the data as if they are different individuals. +no.repeat.id<- +apply(this.index,2, function(x){ +temp<-table(x) +for(i in seq_along(temp)){ +if(temp[i]>1){ #if the subject id appears more than once +num.appearance<-temp[i] #number of times the subject appears in the sample +x[which(x==names(temp)[i])]<-paste0(names(temp)[i],"__",1:num.appearance) #generate new subject ID by concatenating "_#" at the end of the id. Replace the old name with this +} +} +x #return the list of sampled subject ID , now all sample should be unique subject ID. +}) +output<- +apply(no.repeat.id,2,function(x){ +temp<- +sapply(x,function(x_i){ #for each subject +index<-which(sub.id==stringr::word(x_i,1,sep = "\\__")) #index of original data where the subject id appears +cbind(index, "no.repeat.id"=rep(x_i,length(index)))}) #get all observation for this particular subject. +#bind the index and no.repeat.id. as rows +temp.dat<-do.call(rbind, lapply(temp, data.table::data.table)) +complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) +complete.dat[,no.repeat.sub.id=(temp.dat$no.repeat.id)] # add the new subject ID column, with no repetition +} +) +output +} +tt<-boots.samples(dat = example.dat, sub.id = "subjects",B=4) +library(boots.lmer) +output<-boots.samples(dat=example.dat,sub.id = "subjects",B=4) +devtools::use_package( "data.table", pkg = "." ) +usethis::use_package( "data.table", pkg = "." ) +?usethis::use_package +usethis::use_package( "data.table") +getwd() +library(boots.lmer) +library(boots.lmer) +library(boots.lmer) +library(boots.lmer) +library(boots.lmer) +library(boots.lmer) +?boots.lmer::boots.samples +example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") +example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), +"X1"=rpois(n=length(example.subject), lambda = 3), +"X2"=rnorm(n=length(example.subject)), +"X3"=rbeta(n=length(example.subject), shape1 = 3, shape2 = 0.5), +"subjects"=example.subject) +output<-boots.samples(dat=example.dat,sub.id = "subjects",B=4) #create 4 bootstrap samples +output[[1]] #This is the first one! +lmer.out<-boots.lmer(y="Y", X=c("X1","X2","X3"), boots.samples.list = output) +lmer.out +library(boots.lmer) +example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") +example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), +"X"=rpois(n=length(example.subject), lambda = 3), +"subjects"=example.subject) +output<-boots.samples(dat=example.dat,sub.id = "subjects",B=4) #create 4 bootstrap samples +lmer.out<-boots.lmer(y="Y", X=c("X1","X2","X3"), boots.samples.list = output) +lmer.out +library(boots.lmer) +library(boots.lmer) diff --git a/boots.lmer/DESCRIPTION b/boots.lmer/DESCRIPTION index f4cff03..f0dc3bb 100644 --- a/boots.lmer/DESCRIPTION +++ b/boots.lmer/DESCRIPTION @@ -14,5 +14,5 @@ Suggests: knitr, rmarkdown VignetteBuilder: knitr -Imports: +Depends: data.table diff --git a/boots.lmer/NAMESPACE b/boots.lmer/NAMESPACE index f2a981d..7a32f8a 100644 --- a/boots.lmer/NAMESPACE +++ b/boots.lmer/NAMESPACE @@ -2,4 +2,3 @@ export(boots.lmer) export(boots.samples) -import(data.table) diff --git a/boots.lmer/R/boots.lmer.R b/boots.lmer/R/boots.lmer.R index e902442..82e326e 100644 --- a/boots.lmer/R/boots.lmer.R +++ b/boots.lmer/R/boots.lmer.R @@ -9,13 +9,16 @@ #' @examples #' example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") #' example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), -#' "X"=rpois(n=length(example.subject), lambda = 3), -#' "subjects"=example.subject) +#' "X1"=rpois(n=length(example.subject), lambda = 3), +#' "X2"=rnorm(n=length(example.subject)), +#' "X3"=rbeta(n=length(example.subject), shape1 = 3, shape2 = 0.5), +#' "subjects"=example.subject) #' output<-boots.samples(dat=example.dat,sub.id = "subjects",B=4) #create 4 bootstrap samples #' lmer.out<-boots.lmer(y="Y", X=c("X1","X2","X3"), boots.samples.list = output) #' @export boots.lmer<-function(y,X,boots.samples.list,use.formula=NULL){ -library(data.table) + + lmer.fit<-function(y,X,dat,use.formula=NULL){#a function that fits one LMER @@ -50,6 +53,8 @@ library(data.table) parallel::mclapply(boots.samples.list,function(boots.dat){ + #Convert to data table to save time + boots.dat<-data.table::as.data.table(boots.dat) lmer.fit(y=y,X=X,dat=boots.dat)} ,mc.cores = num_workers) diff --git a/boots.lmer/R/boots.samples.R b/boots.lmer/R/boots.samples.R index 1a9ed33..9485a5a 100644 --- a/boots.lmer/R/boots.samples.R +++ b/boots.lmer/R/boots.samples.R @@ -14,7 +14,6 @@ #' "subjects"=example.subject) #' output<-boots.samples(dat=example.dat,sub.id = "subjects",B=4) #create 4 bootstrap samples #' output[[1]] #This is the first one! -#' @import data.table #' @export boots.samples<-function(dat, sub.id,B){ @@ -42,16 +41,26 @@ boots.samples<-function(dat, sub.id,B){ output<- apply(no.repeat.id,2,function(x){ temp<- - sapply(x,function(x_i){ #for each subject + lapply(x,function(x_i){ #for each subject index<-which(sub.id==stringr::word(x_i,1,sep = "\\__")) #index of original data where the subject id appears cbind(index, "no.repeat.id"=rep(x_i,length(index)))}) #get all observation for this particular subject. - #bind the index and no.repeat.id. as rows - temp.dat<-do.call(rbind, lapply(temp, data.table::data.table)) - complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) - complete.dat[,no.repeat.sub.id:=(temp.dat$no.repeat.id)] # add the new subject ID column, with no repetition + + temp.dat<-do.call(rbind, lapply(temp, data.frame)) + complete.dat<-dat[temp.dat$index,] + complete.dat[,"no.repeat.sub.id"]<-temp.dat[,"no.repeat.id"] + return(complete.dat) + + # #bind the index and no.repeat.id. as rows + # temp.dat<-do.call(rbind, lapply(temp, data.table::data.table)) + # complete.dat<-data.table::as.data.table(dat[temp.dat$index,]) + # # complete.dat[,no.repeat.sub.id:=(temp.dat$no.repeat.id)] # add the new subject ID column, with no repetition + # # complete.dat$no.repeat.sub.id<-temp.dat$no.repeat.id + # complete.dat[,"no.repeat.sub.id"]<-temp.dat$no.repeat.id + # return(complete.dat) } ) output } + diff --git a/boots.lmer/vignettes/create_bootstrap_samples.Rmd b/boots.lmer/vignettes/create_bootstrap_samples.Rmd index 2bec087..96b7b01 100644 --- a/boots.lmer/vignettes/create_bootstrap_samples.Rmd +++ b/boots.lmer/vignettes/create_bootstrap_samples.Rmd @@ -13,8 +13,6 @@ knitr::opts_chunk$set( comment = "#>" ) - -options(rmarkdown.html_vignette.check_title = FALSE) ``` diff --git a/boots.lmer/vignettes/create_lmer_fits.Rmd b/boots.lmer/vignettes/create_lmer_fits.Rmd index d6a530f..d405ae3 100644 --- a/boots.lmer/vignettes/create_lmer_fits.Rmd +++ b/boots.lmer/vignettes/create_lmer_fits.Rmd @@ -24,7 +24,7 @@ This vignette shows how to generate LMER fits using the `boots.lmer::boots.lmer` # Generate example data and bootstrap samples Here's an example data and its 4 bootstrap samples.: -```{r , eval=FALSE} +```{r} set.seed(1020) example.subject<-c("Sarah","John","Beth","Anna","Sarah","Sarah","Chris","Blake","John","Anna") example.dat<-data.frame("Y"=rnorm(n=length(example.subject)), @@ -38,3 +38,52 @@ output<-boots.samples(dat=example.dat,sub.id ="subjects",B=4) #a list of 4 boots ``` + +
    + +# Fit LMER to all bootstrap samples + +With the bootstrap samples, we fit the LMER. +```{r} +lmer.out<-boots.lmer(y="Y", X=c("X1","X2","X3"), boots.samples.list = output) + +lmer.out +``` + + + +
    + +# Make an inference with LMER output + +We will generate 5,000 bootstrap samples and fit additive LMER model with random effects. And then we will generate a histogram of estimated effects of `X1`, `X2`, and `X3`. + +```{r cache=TRUE} +set.seed(1204) +output<-boots.samples(dat=example.dat,sub.id ="subjects",B=5000) + +``` + + +Fit LMER: + +```{r cache=TRUE} +lmer.out1<-boots.lmer(y="Y", X=c("X1","X2","X3"), boots.samples.list = output[[100]]) +``` + +Fit LMER: ERROR!! + +Warning in parallel::mclapply(boots.samples.list, function(boots.dat) { : + all scheduled cores encountered errors in user code + +```{r} +lmer.out2<-boots.lmer(y="Y", X=c("X1","X2","X3"), boots.samples.list = output[1:100]) +``` + +From each fit, extract estimated effects + +```{r} +summary(lmer.out[[1]]) +``` + + diff --git a/boots.lmer/vignettes/create_lmer_fits_cache/html/__packages b/boots.lmer/vignettes/create_lmer_fits_cache/html/__packages new file mode 100644 index 0000000..67c0ce1 --- /dev/null +++ b/boots.lmer/vignettes/create_lmer_fits_cache/html/__packages @@ -0,0 +1,2 @@ +data.table +boots.lmer diff --git a/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-4_a01d30e1a912167e6fe428c5ae4d6d36.RData b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-4_a01d30e1a912167e6fe428c5ae4d6d36.RData new file mode 100644 index 0000000..a9a5666 Binary files /dev/null and b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-4_a01d30e1a912167e6fe428c5ae4d6d36.RData differ diff --git a/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-4_a01d30e1a912167e6fe428c5ae4d6d36.rdb b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-4_a01d30e1a912167e6fe428c5ae4d6d36.rdb new file mode 100644 index 0000000..7921852 Binary files /dev/null and b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-4_a01d30e1a912167e6fe428c5ae4d6d36.rdb differ diff --git a/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-4_a01d30e1a912167e6fe428c5ae4d6d36.rdx b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-4_a01d30e1a912167e6fe428c5ae4d6d36.rdx new file mode 100644 index 0000000..43a3fe7 Binary files /dev/null and b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-4_a01d30e1a912167e6fe428c5ae4d6d36.rdx differ diff --git a/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-5_e51ea077a3876c8218cf06a0ec5aefd2.RData b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-5_e51ea077a3876c8218cf06a0ec5aefd2.RData new file mode 100644 index 0000000..bc24016 Binary files /dev/null and b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-5_e51ea077a3876c8218cf06a0ec5aefd2.RData differ diff --git a/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-5_e51ea077a3876c8218cf06a0ec5aefd2.rdb b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-5_e51ea077a3876c8218cf06a0ec5aefd2.rdb new file mode 100644 index 0000000..69a6b93 Binary files /dev/null and b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-5_e51ea077a3876c8218cf06a0ec5aefd2.rdb differ diff --git a/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-5_e51ea077a3876c8218cf06a0ec5aefd2.rdx b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-5_e51ea077a3876c8218cf06a0ec5aefd2.rdx new file mode 100644 index 0000000..7e47757 Binary files /dev/null and b/boots.lmer/vignettes/create_lmer_fits_cache/html/unnamed-chunk-5_e51ea077a3876c8218cf06a0ec5aefd2.rdx differ diff --git a/boots.lmer_0.0.0.9000.tar.gz b/boots.lmer_0.0.0.9000.tar.gz index 0dff1c1..3de1687 100644 Binary files a/boots.lmer_0.0.0.9000.tar.gz and b/boots.lmer_0.0.0.9000.tar.gz differ