R/ECOLOGIST.R
In DecisionNeurosciencePsychopathology/redcap_in_r: REDCAP IN R
Defines functions
bsrc.ema.loopit
bsrc.ema.procActualData
bsrc.ema.oneshotupload
dnpl.ema.statsbyweek
dnpl.ema.missinggraph
dnpl.ema.spiltraw
dnpl.ema.infochange
dnpl.ema.addmorestuff
dnpl.ema.procdb
dnpl.ema.updatevariref
bsrc.ema.scaletonum
bsrc.ema.patch
bsrc.ema.getevent
bsrc.ema.redcapupload
bsrc.ema.progress.graph
bsrc.ema.singlesubproc
bsrc.ema.main
bsrc.ema.rawtolist
bsrc.ema.getfile
bsrc.ema.mwredcapmatch
bsrc.ema.update
cleanupdf
###############################################################################################################
# ECOLOGIST scripts for EMA related functions #
# #
# bsrc.ema.mwredcapmatch(): Do mw redcap id match and produce a localmatch df, mainly used in bsrc.getfile() #
# bsrc.getfile(): Modify trigger names and add RedCap ID based on matching, mainly used in bsrc.ema.loopit() #
# bsrc.ema.main(): Preprocess single participant and produce a processed completion rate df, #
# mainly used in bsrc.ema.loopit() #
# bsrc.ema.progress.graph(): Graphing function for bsrc.ema.main() #
# bsrc.ema.redcapupload(): Reshape single subject df completion rate df into RedCap upload friendly format, #
# mainly used in bsrc.ema.loopit() #
# bsrc.ema.getevent(): Grab raw data by Survey. This is mainly eliminated, in favor of the new data #
# organization; mainly used in bsrc.ema.patch() #
# bsrc.ema.patch(): Patch raw data to add mircoburst related variables for better processing, #
# mainly used in bsrc.ema.main() #
# bsrc.ema.scaletonum(): Change survey answer to numeric value, mainly used in bsrc.ema.patch() #
# bsrc.ema.loopit(): Wrapping function for the data preprocessing pipeline, it perform the following: #
# 1) Grab the raw data from file system and transform it to data frame #
# a) For Ver.2, loop around all data files #
# b) For Ver.3, separate raw data by subject and loop around subjects who are not in #
# database. #
# 2) Push raw through bsrc.ema.main() and then bsrc.ema.redcapupload() #
# a) However, will not upload right away #
# 3) When completed, merge new participant who had now completed to previous data; and #
# merge all the incomplete/in progress participant's redcap data #
# 4) Upload the redcap data to redcap #
# 5) Assign data back into environment, then save back to file #
# 6) Allow additional pre-processing to be done with dnpl.ema.procdb() #
# dnpl.ema.updatevariref(): Very unhelpful function used in creating metadata for EMA database, rarely used #
# dnpl.ema.procdb(): Wrapper for additional preprocessing for the data, used in bsrc.ema.loopit() #
# dnpl.ema.infochange(): Reword info dataframe that's generated by bsrc.ema.main() #
# dnpl.ema.spiltraw(): Spilt raw data into different data frames #
# dnpl.ema.missinggraph(): Graphic representation of missingness by subject #
# dnpl.ema.meanbyweek(): Calculate mean completion rate by week #
# #
# NO LONGER USEFUL REALLY: #
# bsrc.ema.oneshotupload(): Once a upon time...there were multiple user data to process at once. Tis the loop #
# #
# Legacy time convertion #
# subactivity$fordate <- as.Date(strptime(subactivity$For.Time, '%d/%m/%Y %H:%M:%S')) #
# #
###############################################################################################################
####Utilities
cleanupdf<-function(dfx,req.varinames=NULL){
dfx<-dfx[which(apply(dfx,2,function(s){any(!is.na(s))}))]
if(!is.null(req.varinames)){
dfx[req.varinames[which(!req.varinames %in% names(dfx))]]<-NA
}
return(dfx)
}
################Main Wrapper Function:
bsrc.ema.update<-function(raw_fpath=file.choose(),ema_raw=NULL,protocol=protocol.cur,defaultchoice=NULL,
emardpath=rdpaths$ema,ss.graph=T,graph_path=ema.graph.path,metadata.ema=NULL,
local=F,restrictData=T, forceRerun=F, updateRC=T, updateDB=T,excludeID=c("")){
#Initialization:
if(is.null(ema_raw)){ema_raw<-read.csv(raw_fpath,stringsAsFactors = F)}
rc_ema<-bsrc.getform(formname = c("record_registration","ema_session_checklist"),grabnewinfo = !local, protocol = protocol)
if(file.exists(emardpath)){
envir_ema<-bsrc.attachngrab(emardpath)
#envir_ema<-bsrc.attachngrab("ema_test.rdata")
if(is.null(metadata.ema)){metadata.ema <- envir_ema$metadata.ema}
} else { if(is.null(metadata.ema)) {stop("This function can't generate metadata object, will terminate if not provided.")}
envir_ema<-as.environment(list(fulldata.ema=list(raw_data=list(),proc_data=list(),progress_data=list(),info=data.frame(stringsAsFactors = F)),
metadata.ema=metadata.ema))
}
completed_raw<-envir_ema$fulldata.ema$raw_data
completed_proc<-envir_ema$fulldata.ema$proc_data
completed_prog<-envir_ema$fulldata.ema$progress_data
completed_info<-envir_ema$fulldata.ema$info
finished_ID<-as.character(completed_info$RedcapID[which(completed_info$Status %in% c("COMPLETED","EARLY-TERMINATION"))])
finished_ID<-finished_ID[finished_ID %in% names(completed_proc)]
#
# ema_raw_old_proc<-envir_ema$fulldata.ema$raw
# ema_raw_old_proc<-as.data.frame(apply(ema_raw_old_proc,2,as.character),stringsAsFactors = F)
# completed<-bsrc.ema.rawtolist(ema_raw = ema_raw_old_proc, rc_ema = rc_ema, envir_ema = envir_ema)
#
ema_split<-bsrc.ema.rawtolist(ema_raw = ema_raw, rc_ema = rc_ema, envir_ema = envir_ema,protocol=protocol,defaultchoice=defaultchoice)
matchdb <- envir_ema$matchdb
# new_info[which(new_info$CompletionRate < 0.1),]
#
if(!forceRerun){
message("These folks had completed, no need to reprocess: ", paste(finished_ID,collapse = " "))
ema_split_filter<-ema_split[!names(ema_split) %in% finished_ID]
} else {ema_split_filter<-ema_split}
#We replace old raw and get new ones here:
completed_raw<-completed_raw[which(!names(completed_raw) %in% names(ema_split_filter))]
new_raw<-c(completed_raw,ema_split_filter)
# completed_sub<-lapply(X = completed,FUN = bsrc.ema.singlesubproc,graphic=F,graph_path=graph_path)
pData_allsub<-lapply(X = ema_split_filter,FUN = bsrc.ema.singlesubproc,graphic=ss.graph,graph_path=graph_path,restrictData=restrictData)
# completed_prog<-lapply(completed_sub,function(xz){xz$data})
ema_progress_n<-lapply(pData_allsub,function(xz){xz$data})
completed_prog<-completed_prog[which(!names(completed_prog) %in% names(ema_progress_n))]
new_progress<-c(completed_prog,ema_progress_n)
# completed_info<-do.call(rbind,lapply(completed_sub,function(xz){xz$info}))
# completed_info<-completed_info[order(completed_info$EndDate,decreasing = T),]
ninfo.df<-do.call(rbind,lapply(pData_allsub,function(xz){xz$info}))
completed_info<-completed_info[which(!as.character(completed_info$RedcapID) %in% as.character(ninfo.df$RedcapID) ),]
new_info<-rbind(completed_info,ninfo.df)
new_info<-new_info[order(new_info$EndDate,decreasing = T),]
#completed_proc<-lapply(completed_raw,bsrc.ema.procActualData,metadata.ema=metadata.ema)
ema_proc_n<-lapply(ema_split_filter,bsrc.ema.procActualData,metadata.ema=metadata.ema)
completed_proc<-completed_proc[which(!names(completed_proc) %in% names(ema_proc_n))]
new_proc<-c(completed_proc,ema_proc_n)
ema_rc_all<-ProcApply(pData_allsub,function(ema_lss){
#message(ema_lss$info$RedcapID)
if(!is.null(ema_lss$data)){
bsrc.ema.redcapupload(emamelt.merge = ema_lss$data,startdate = (ema_lss$info$StartDate)-1,
enddate = ema_lss$info$EndDate,funema = rc_ema,output = T,
ifupload = F,curver = "3",idvar = "RedCapID")
} else {return(NULL)}
})$df
#return(ema_rc_all)
if(is.data.frame(ema_rc_all) && nrow(ema_rc_all)>0){
ema_rc_all<-as.data.frame(apply(ema_rc_all[!is.na(ema_rc_all$registration_redcapid),],2,as.character))
if(updateRC){
print(ema_rc_all)
result.rc_all<-REDCapR::redcap_write(ema_rc_all,token = protocol$token,redcap_uri = protocol$redcap_uri)
if (result.rc_all$success) {message("Updated these IDs: ",paste(ema_rc_all$registration_redcapid,collapse = " "))}
} else {message("RedCap Update failed.")}
} else {
message("Nothing to update, go away.")
}
if(updateDB) {
fulldata.ema<-list(info=new_info,progress_data=new_progress,proc_data=new_proc,raw_data=new_raw,update.date=Sys.Date(),ver.tag=4)
save(list=c("metadata.ema","fulldata.ema","matchdb"),file = emardpath)
}
message("DONE.")
}
#################
#EMA 3 Exclusive Functions; match metricwire user ID to redcap ID
bsrc.ema.mwredcapmatch<-function(ema3.raw=NULL,funema=NULL,envir=NULL,defaultchoice=NULL,...) {
ema3<-ema3.raw
ema3$ema_id[which(ema3$ema_id=="")]<-NA
ema3a<-ema3[!duplicated(ema3[c("User_Id","ema_id")]),c("User_Id","ema_id")]
ema3a<-ema3a[order(ema3a$ema_id),]
localmatch<-ema3a[!(duplicated(ema3a$User_Id) & is.na(ema3a$ema_id)),]
names(localmatch)<-c("ema_studyidentifier","registration_redcapid")
localmatch<-localmatch[!duplicated(localmatch),]
localmatch$registration_redcapid[is.na(localmatch$registration_redcapid)]<-"UNKNOWN"
localmatch$origin <- "Source"
if(is.null(funema)) {funema<-bsrc.getform(formname = "ema_session_checklist",grabnewinfo = T,...)}
rcmatch<-na.omit(funema[c("ema_studyidentifier","registration_redcapid")])
rcmatch$origin <- "RedCap"
if (!is.null(envir) & exists("matchdb",envir = envir)){matchdb<-get("matchdb",envir = envir)}else{matchdb<-data.frame(ema_studyidentifier=NA,registration_redcapid=NA)}
matchdb$origin <- "Existing"
summatch<-rbind(localmatch,rcmatch,matchdb)
summatch_sp<-split(summatch,summatch$ema_studyidentifier)
postmatch<-lapply(summatch_sp,function(dbax){
#print(unique(dbax$ema_studyidentifier))
if(length(unique(dbax$registration_redcapid))>1) {
if("Existing" %in% dbax$origin && "RedCap" %in% dbax$origin) {
if(dbax$registration_redcapid[which(dbax$origin == "Existing")] == dbax$registration_redcapid[which(dbax$origin == "RedCap")] ) {
return(dbax[which(dbax$origin=="Existing"),c("ema_studyidentifier","registration_redcapid")])
}
}
message(paste("This MetricWire Identifier: [",unique(dbax$ema_studyidentifier),"] has inconsistant IDs:") )
message(paste(dbax$registration_redcapid,dbax$origin,sep = " from ",collapse = " , ") )
if(is.null(defaultchoice)){
whichonetoget<-readline(prompt = "Please type in the source of the actual ID, type 'SKIP' to ignore this person: ")
} else {message("The default choice was set to: ", defaultchoice,". No need to ask.")
whichonetoget <- defaultchoice
}
if(whichonetoget == "SKIP") {return(NULL)} else {return(dbax[which(dbax$origin==whichonetoget),c("ema_studyidentifier","registration_redcapid")])}
} else {
return(unique(dbax[c("ema_studyidentifier","registration_redcapid")]))
}
})
postmatch <- do.call(rbind,postmatch)
row.names(postmatch)<-NULL
assign("matchdb",postmatch,envir = envir)
return(postmatch)
#
}
############### General Get File
bsrc.ema.getfile<-function(filename, curver="2",funema=NULL,envir=NULL,...){
if (missing(filename)) {
message("No file specified, please choose the target file")
filename<-file.choose()
}
tryCatch({
emadata.raw<- read.csv(filename, stringsAsFactors=FALSE)
}, error=function(x){
}) #find function
run2<-F
run3<-F
switch(curver, "2" = {run2<-T}, "3" = {run3<-T})
if (run2){
if(is.null(funema)) {funema<-bsrc.getform(formname = "ema_session_checklist",grabnewinfo = T)}
variname<-read.csv("variname.csv") #find variname
variname<-as.character(variname$variname)
names(emadata.raw)<-as.list(variname)
mwmatch<-data.frame(funema$registration_redcapid,funema$ema_studyidentifier)
names(mwmatch)<-c('registration_redcapid','ema_studyidentifier')
emadata.raw$RedcapID<-mwmatch$registration_redcapid[match(emadata.raw$User_Id,mwmatch$`ema_studyidentifier`)]
RedcapID<-unique(emadata.raw$RedcapID)
emadata.raw$Survey_Class<-emadata.raw$TriggerName
emadata.raw$Survey_Class[which(!emadata.raw$Survey_Class %in% c("BoD","EoD","DoD"))]<-"MB"
emadata.raw$Survey_Class<-as.character(emadata.raw$Survey_Class)
d<-as.Date(emadata.raw$Survey_Submitted_Date,format = "%d/%m/%Y")
emadata.raw$Survey_Submitted_Date<-as.Date(ifelse(d < "2012-12-31", format(d, "20%y-%m-%d"), format(d)))
d<-as.Date(emadata.raw$Survey_Started_Date,format = "%d/%m/%Y")
emadata.raw$Survey_Started_Date<-as.Date(ifelse(d < "2012-12-31", format(d, "20%y-%m-%d"), format(d)))
d<-as.Date(emadata.raw$TriggerDate,format = "%d/%m/%Y")
emadata.raw$TriggerDate<-as.Date(ifelse(d < "2012-12-31", format(d, "20%y-%m-%d"), format(d)))}
if(run3) {
if(is.null(funema)) {funema<-bsrc.getform(formname = "ema_session_checklist",grabnewinfo = T)}
emadata.raw<-emadata.raw[which(emadata.raw$User_Id!=""),]
emadata.raw$Survey_Class<-emadata.raw$TriggerName
emadata.raw$Survey_Class[which(emadata.raw$Survey_Class %in% c("BoD_U"))]<-"BoD"
emadata.raw$Survey_Class[which(emadata.raw$Survey_Class %in% c("DoD_U"))]<-"DoD"
emadata.raw$Survey_Class[which(emadata.raw$Survey_Class %in% c("EoD_U"))]<-"EoD"
emadata.raw$Survey_Class[which(emadata.raw$Survey_Class %in% c("SetUp"))]<-"SetUp"
emadata.raw$Survey_Class[which(!emadata.raw$Survey_Class %in% c("BoD","EoD","DoD","SetUp",""))]<-"MB"
idmatch<-bsrc.ema.mwredcapmatch(emadata.raw,funema=funema,envir=envir,...)
emadata.raw$RedcapID<-idmatch$registration_redcapid[match(emadata.raw$User_Id, idmatch$ema_studyidentifier)]
lRedcapID<-unique(emadata.raw$RedcapID)
emadata.raw$Survey_Started_Date<-as.Date(emadata.raw$Survey_Started_Date)
emadata.raw$Survey_Submitted_Date<-as.Date(emadata.raw$Survey_Submitted_Date)
emadata.raw$TriggerDate<-as.Date(emadata.raw$TriggerDate)
}
return(emadata.raw)
}
###############Updated Get file function for list:
bsrc.ema.rawtolist<-function(ema_raw=NULL,rc_ema=NULL,envir_ema=NULL,protocol=protocol,...){
message("bsrc.ema.rawtolist only works with data collected post version 3a update. Previous Data please manually laod them as list and rbind.")
#Clean Up
ema_raw<-ema_raw[which(ema_raw$User_Id!=""),]
ema_raw[ema_raw==""]<-NA
ema_raw[grep("Date",names(ema_raw))]<-as.data.frame(lapply(ema_raw[grep("Date",names(ema_raw))],as.Date))
ema_raw$Survey_Class<-gsub("_U","",ema_raw$TriggerName)
ema_raw$Survey_Class[which(!ema_raw$Survey_Class %in% c("BoD","EoD","DoD","SetUp",""))]<-"MB"
ema_idmatch<-bsrc.ema.mwredcapmatch(ema3.raw = ema_raw,funema = rc_ema,envir = envir_ema,...)
ema_raw<-bsrc.ema.scaletonum(ema_raw)
#Get Info From REDCAP
ema_raw$RedcapID<-ema_idmatch$registration_redcapid[match(x = ema_raw$User_Id,table = ema_idmatch$ema_studyidentifier)]
ema_raw<-ema_raw[ema_raw$RedcapID!="REMOVE",]
ema_raw<-ema_raw[which(ema_raw$User_Id %in% ema_idmatch$ema_studyidentifier),]
ema_raw$Initial<-rc_ema$registration_initials[match(x = ema_raw$RedcapID,table = rc_ema$registration_redcapid)]
ema_raw$Group<-rc_ema$registration_group[match(x = ema_raw$RedcapID,table = rc_ema$registration_redcapid)]
group_valuemap<-bsrc.getchoicemapping(variablenames = "registration_group",protocol = protocol)
ema_raw$Group<-plyr::mapvalues(ema_raw$Group,from = group_valuemap$choice.code,to = group_valuemap$choice.string,warn_missing = F)
ema_raw$TermDate<-rc_ema[rc_ema$redcap_event_name=="ema_arm_1",]$ema_termdate[match(x = ema_raw$RedcapID,table = rc_ema[rc_ema$redcap_event_name=="ema_arm_1",]$registration_redcapid)]
ema_raw$SetUpDate<-rc_ema[rc_ema$redcap_event_name=="ema_arm_1",]$ema_setuptime[match(x = ema_raw$RedcapID,table = rc_ema[rc_ema$redcap_event_name=="ema_arm_1",]$registration_redcapid)]
#Proc Date Time
ema_raw<-bsrc.ema.patch(emadata.raw = ema_raw,vers = "2",skipgetevent = T)
ema_raw$DateTime<-strptime(paste(ema_raw$Survey_Submitted_Date,ema_raw$Survey_Submitted_Time,sep = " "),format = "%Y-%m-%d %H:%M")
ema_raw<-ema_raw[order(ema_raw$RedcapID),]
ema_split<-split(ema_raw,ema_raw$RedcapID)
names(ema_split)->ls_rcid
return(ema_split)
}
############### EMA2 Main function:
##### urrently hard fixed for EMA 3; new main function needed:
bsrc.ema.main<-function(emadata.raw,path=NULL,graphic=T, gprint=T,subreg=NULL,funema=NULL,protocol=protocol.cur,...){
message("BE AWARE! THIS FUNCTION IS GETTING DEPRECIATED AND A NEW FUNCTION WILL TAKE ITS PLACE SOON.")
if (missing(emadata.raw)){
print("Using bsrc.ema.getfile() for data")
emadata.raw<-bsrc.ema.getfile(curver = "2")
}
if (is.null(subreg)){
subreg<-bsrc.getevent(eventname = "enrollment_arm_1",subreg = T,... = ...)
}
#Require a safeguard of the emadata.raw because the SetUp might bring up the start date earlier than actual:
emadata.raw[which(emadata.raw$Survey_Class %in% c("BoD","EoD","DoD","MB")),]->emadata.raw
#MAKE SURE TO CHECK REDCAP
#Here is where you can do multiple ID processing loop: However, it might not be even useful bc individual files
#Currently take out nas, should only be one item:
RedcapID<-as.character(unique(emadata.raw$RedcapID))
print(RedcapID)
Initial<-as.character(unique(subreg$registration_initials[match(RedcapID,subreg$registration_redcapid)]))
DeviceOS<-as.character(unique(emadata.raw$DeviceOS))
if ("J WOO" %in% Initial) {
RedcapID<-as.character(RedcapID[1])
Initial<-as.character(Initial[1])
DeviceOS<-as.character(emadata.raw$DeviceOS[1])
}
if (length(DeviceOS)>1) {
DeviceOS<-paste(DeviceOS,collapse = "/")
}
if (length(RedcapID)>1){stop("ema.main() can only process only 1 ID data at a time, please filter")}
mwuserid<-as.character(unique(emadata.raw$User_Id[which(emadata.raw$RedcapID==RedcapID)]))
#Patch the data
tryCatch({
emadata.raw<-bsrc.ema.patch(emadata.raw = emadata.raw,vers = "2")},error=function(e) {})
#Read EMA Data:
table.emadata<-data.table::data.table(emadata.raw$RedcapID,emadata.raw$Survey_Submitted_Date,emadata.raw$Survey_Class)
names(table.emadata)<-c("redcapID","date","Type")
table.emadata<-table.emadata[order(table.emadata$Type,table.emadata$date),]
table.emadata[,count:=seq_len(.N), by=Type]
table.emadata[table.emadata$Type=="MB",count:=seq_len(.N), by=date]
table.emadata<-na.omit(table.emadata)
#table.emadata<-table.emadata[which(table.emadata$Type %in% c("DoD","BoD","EoD"))]
table.emadata$redcapID<-as.character(table.emadata$redcapID)
#Safe guard the function from god damn health controls who don't get any negative interaction whatsoever.
if (!any(table.emadata$Type=='MB')) {
table.emadata[1,]->temp
temp$Type<-"MB"
temp$count<-0
table.emadata<-rbind(table.emadata,temp)
emadata.raw$MBYES<-FALSE
}
if (!any(table.emadata$Type=='BoD')) {
table.emadata[1,]->temp
temp$Type<-"BoD"
temp$count<-0
table.emadata<-rbind(table.emadata,temp)
}
if (!any(table.emadata$Type=='DoD')) {
table.emadata[1,]->temp
temp$Type<-"DoD"
temp$count<-0
table.emadata<-rbind(table.emadata,temp)
}
if (!any(table.emadata$Type=='EoD')) {
table.emadata[1,]->temp
temp$Type<-"EoD"
temp$count<-0
table.emadata<-rbind(table.emadata,temp)
}
#Aggregate Total:
emadata<-aggregate(table.emadata,FUN = max,by=list(interaction(table.emadata$date,table.emadata$Type)))
emadata$Group.1<-NULL
emadata<-reshape(emadata,idvar = "date",timevar = "Type",direction = "wide", v.names = c("count"))
emadata<-emadata[order(emadata$date),]
names(emadata)<-c("redcapID","date","BoD","DoD","EoD","MB")
emadata$MB[which(is.na(emadata$MB))]<-0
emadata<-zoo::na.locf(emadata,na.rm=F)
emadata$date<-as.Date(emadata$date)
emadata[is.na(emadata)]<-0
emadata$Total<-as.numeric(emadata$BoD)+as.numeric(emadata$DoD)+as.numeric(emadata$EoD)
#Generate Expectation Grid:
lengthofema<-21
startdate<-as.Date(funema$ema_setuptime[which(funema$registration_redcapid %in% RedcapID & funema$ema_setuptime!="")])
enddate<-startdate+lengthofema
emaseqdate<-seq.Date(from=startdate,to=enddate,by="days")
emaseq.one<-seq(from=0,to=lengthofema,length.out = length(emaseqdate))
emaseq.six<-seq(from=0,to=(6*lengthofema),length.out = length(emaseqdate))
emaseq.total<-seq(from=0,to=(8*lengthofema),length.out = length(emaseqdate))
ematotal.donly<-as.data.frame(emaseqdate)
names(ematotal.donly)<-c("date")
ematotal<-ematotal.donly
ematotal$BoD<-emaseq.one
ematotal$EoD<-emaseq.one
ematotal$DoD<-emaseq.six
#Replace enddate to termination if earlier than expected (def could do better here)
terminationdate<-as.Date(funema$ema_termdate[which(funema$registration_redcapid==RedcapID & funema$ema_termdate!="")])
if (length(terminationdate)>0){
if ((terminationdate-1) < enddate){enddate<-terminationdate}
if ((terminationdate-1) > enddate){
message("THIS PERSON HAS DATA PASS 21 DAYS SINCE START DATE")
enddate<-terminationdate
}
}
#basic info
info<-data.frame(RedcapID,Initial,startdate,enddate,mwuserid,DeviceOS)
if (any(emadata.raw$MBYES)) {
mbonly<-data.table::as.data.table(emadata.raw[which(emadata.raw$MBYES),c("Survey_Submitted_Date","MBCount")])
mbonly<-mbonly[, sum(MBCount), by = Survey_Submitted_Date]
names(mbonly)<-c("date","MB")
ematotal<-merge(ematotal,mbonly,all=T)
ematotal$MB[which(is.na(ematotal$MB))]<-0
} else {ematotal$MB<-0}
ematotal$Total<-as.numeric(ematotal$BoD)+as.numeric(ematotal$DoD)+as.numeric(ematotal$EoD)
ematotal.melt<-reshape2::melt(ematotal,id.var='date',variable.name="Type",value.name="expectation")
#melt data
emadata.full<-merge(ematotal.donly,emadata,all = T)
emadata.full<-zoo::na.locf(emadata.full)
emadata.full.melt<-reshape2::melt(emadata.full,id.var=c("redcapID","date"), measure.vars=c("BoD","DoD","EoD","Total","MB"),variable.name="Type",value.name="actual")
emadata.full.melt$date<-as.Date(emadata.full.melt$date)
#New Merge
emamelt.merge<-merge(emadata.full.melt,ematotal.melt,all=T)
emamelt.merge<-emamelt.merge[which(!emamelt.merge$date==startdate),] #Take out startdate
emamelt.merge<-emamelt.merge[which(!emamelt.merge$date>ifelse(enddate>Sys.Date(),Sys.Date(),enddate)),]
emamelt.merge$actual<-as.numeric(emamelt.merge$actual)
emamelt.merge$expectation<-as.numeric(emamelt.merge$expectation)
emamelt.merge$diff<-emamelt.merge$actual - emamelt.merge$expectation
emamelt.merge$porp<-round(emamelt.merge$actual / emamelt.merge$expectation *100,2)
emamelt.merge$per<-paste(emamelt.merge$porp, "%")
emamelt.merge$Type<-as.character(emamelt.merge$Type)
if (graphic){
bsrc.ema.progress.graph(emamelt.merge = emamelt.merge, path = path, startdate = startdate, enddate = enddate, output = gprint, Initial = Initial)
#End Graphic
}
return(list(data=emamelt.merge,info=info))
}
###############Universal EMA Main function: Single Subject:
bsrc.ema.singlesubproc<-function(ema_ss=NULL,graphic=T,graph_path=ema.graph.path,restrictData=F){
tryCatch({
if(is.null(graph_path)){graphic<-F}
message("")
message("##############")
message("Processing participant...ID: [",unique(ema_ss$RedcapID),"]...Initial: [",unique(ema_ss$Initial),"]")
ema_ss<-ema_ss[order(ema_ss$Survey_Class),]
ema_ss_s<-split(ema_ss,ema_ss$Survey_Class)
#Get the SetUp
if(!is.null(ema_ss$ema_waketime_u)){
setup_ema<-ema_ss[ema_ss$DateTime==max(ema_ss$DateTime[!is.na(ema_ss$ema_waketime_u)]) & !is.na(ema_ss$ema_waketime_u),
c("RedcapID","ema_startdate","ema_waketime_u","ema_bedtime_u")]
names(setup_ema)<-c("RedcapID","StartDate","WakeTime","BedTime")
}else{
setup_ema<-data.frame()
}
#Get the SetUp for version 2
if(nrow(setup_ema)<1){
message("This is probably a version 2 participant...we have to make it up on the fly!")
setup_ema<-data.frame(RedcapID=unique(ema_ss$RedcapID),
StartDate=unique(as.Date(ema_ss$SetUpDate))+1,
WakeTime="01:00",BedTime="23:59",stringsAsFactors = F)
}
#Do correction:
if(setup_ema$StartDate!=unique(as.Date(ema_ss$SetUpDate))+1){
message("This person's SetUp date is incongruent with their redcap setup date. Will use the redcap one.")
setup_ema$StartDate<-unique(as.Date(ema_ss$SetUpDate))+1
}
seqDate_og<-seq.Date(from = as.Date(setup_ema$StartDate),to = as.Date(setup_ema$StartDate)+20,by = "days")
#Check for outside of the window:
minDateTime<-strptime(paste(min(seqDate_og),setup_ema$WakeTime,sep = " "),format = "%Y-%m-%d %H:%M")
maxDateTime<-(strptime(paste(max(seqDate_og),"23:00",sep = " "),format = "%Y-%m-%d %H:%M")+12*60*60)
logicDateTime<-dplyr::between(as.numeric(ema_ss$DateTime),left = as.numeric(minDateTime),right = as.numeric(maxDateTime)) | ema_ss$Survey_Class=="SetUp"
if(any(!logicDateTime)){
message("This subject has data outside of the 21 days window.")
if(restrictData) {
message("restrictData argument is on, therefore will omit any data outside of the 21 days window! But we will keep the raw data.")
} else {
message("restrictData argument is off, will keep all data.")
seqDate_og<-unique(c(unique(ema_ss[ema_ss$Survey_Class!="SetUp",]$Survey_Submitted_Date)[!unique(ema_ss[ema_ss$Survey_Class!="SetUp",]$Survey_Submitted_Date) %in% seqDate_og],seqDate_og))
}
}
if(!is.na(unique(ema_ss$TermDate))){seqDate_og<-seqDate_og[seqDate_og<=as.Date(unique(ema_ss$TermDate))]}
seqDate<-seqDate_og[seqDate_og<as.Date(Sys.Date())]
message("Days in the study: [",length(seqDate),"]")
#Didn't use lapply because accumulation complications;
lpData<-list()
for(inj in 1:length(seqDate)) {
#if(inj>0){
xdate<-seqDate[[inj]]
todayls<-lapply(ema_ss_s,function(ss_x){
StartDateTime<-strptime(paste(xdate,setup_ema$WakeTime,sep = " "),format = "%Y-%m-%d %H:%M")
EndDateTime<-(strptime(paste(xdate,setup_ema$BedTime,sep = " "),format = "%Y-%m-%d %H:%M")+2*60*60)
if(as.numeric(EndDateTime) < as.numeric(StartDateTime)) {EndDateTime <- EndDateTime+(24*60*60)}
dfx_dj<-ss_x[which(dplyr::between(x = as.numeric(ss_x$DateTime),
left = as.numeric(StartDateTime),
right = as.numeric(EndDateTime))),]
})
todayls$SetUp<-NULL
expectls<-list(BoD=1,EoD=1,DoD=6,MB=sum(todayls$DoD$MB_Timepoint,na.rm = T))
expectls$Total<-sum(unlist(expectls[c("BoD","DoD","EoD")]),na.rm = T)
actual<-lapply(todayls,nrow)
actual$Total<-sum(unlist(actual[c("BoD","DoD","EoD")]),na.rm = T)
finaldf<-do.call(rbind,lapply(c(names(todayls),"Total"),function(gx){
if(inj>1){
pdfx<-lpData[[inj-1]]
init_actual<-pdfx$actual[pdfx$Type==gx]
init_expect<-pdfx$expectation[pdfx$Type==gx]} else {
init_actual<-0
init_expect<-0}
data.frame(Type=gx,actual=(actual[[gx]]+init_actual),expectation=(expectls[[gx]]+init_expect))
}))
finaldf$date<-xdate
finaldf$daysinstudy<-as.numeric(as.Date(xdate)-(as.Date(setup_ema$StartDate)-1))
lpData[[inj]]<-finaldf
#}
}
pData<-do.call(rbind,lpData)
rownames(pData)<-NULL
pData<-pData[which(!(pData$actual==0 & pData$expectation==0)),]
pData$RedCapID<-unique(ema_ss$RedcapID)
pData$diff<-pData$actual - pData$expectation
pData$porp<-pData$actual / pData$expectation
pData$per <-paste0(round(pData$porp*100,2)," %")
info_ss<-data.frame(RedcapID=unique(ema_ss$RedcapID),Initial=unique(ema_ss$Initial), Group=unique(ema_ss$Group),
StartDate=min(seqDate_og),EndDate=max(seqDate_og),MWUserID=paste(unique(ema_ss$User_Id),collapse = "/"),
DeviceOS=paste(unique(ema_ss$DeviceOS),collapse = "/"))
info_ss$Status<-"UNKNOWN"
info_ss$Status[info_ss$StartDate<=Sys.Date()]<-"IN-PROGRESS"
info_ss$Status[info_ss$StartDate>Sys.Date()]<-"HAVEN'T STARTED"
info_ss$Status[info_ss$EndDate<Sys.Date() & length(seqDate)==21]<-"COMPLETED"
info_ss$Status[info_ss$EndDate<Sys.Date() & length(seqDate)<21]<-"EARLY-TERMINATION"
info_ss$Status[info_ss$EndDate<Sys.Date() & length(seqDate)>21]<-"EXCESSIVE"
info_ss$Duration<-length(seqDate)
if(is.data.frame(pData) && nrow(pData)>0){
if (graphic){
bsrc.ema.progress.graph(emamelt.merge = pData, path = graph_path, startdate = min(seqDate_og), enddate = max(seqDate_og),
output = T, Initial = unique(ema_ss$Initial))
}
info_ss$CompletionRate<-pData$porp[pData$Type=="Total" & (pData$daysinstudy==max(pData$daysinstudy))]
if(any(pData$Type=="MB")){
info_ss$MBCount<-pData$expectation[pData$Type=="MB" & (pData$daysinstudy==max(pData$daysinstudy))]
info_ss$MBProp<-pData$porp[pData$Type=="MB" & (pData$daysinstudy==max(pData$daysinstudy))]
} else {
info_ss$MBCount<-0
info_ss$MBProp<-NA
}
} else {
message("No data yet. Skipping")
pData<-NULL
info_ss$CompletionRate<-NA
info_ss$MBCount<-0
info_ss$MBProp<-NA
}
message("#####DONE#####")
message("")
return(list(data=pData,info=info_ss))
},error=function(e){message(e)})
}
#########Graphing function:
bsrc.ema.progress.graph<-function(emamelt.merge=NULL, path = getwd(), startdate=NULL,enddate=NULL, output=T, codeout=F,Initial=NULL,...) {
require('ggplot2')
#Safe guard the function:
if(is.data.frame(emamelt.merge) && nrow(emamelt.merge)>0){
#Safe guard the plot:
emamelt.merge<-emamelt.merge[emamelt.merge$Type!="MB",]
#Percentage Plot
emaplot.percent<-ggplot(data = emamelt.merge, aes(x=date, y=porp, group=Type, shape=Type, color=Type)) +
ggtitle(paste(Initial,"EMA Progress (Percentage)"))+
theme(plot.title = element_text(hjust = 0.5))+
geom_line()+
ylab("Percentage")+
scale_x_date(name="Date",limits = c(startdate+1,NA) ,date_breaks = "2 days")+
geom_point()+
ggrepel::geom_label_repel(data = emamelt.merge[(which(emamelt.merge$date %in% c(startdate+7,startdate+14,ifelse(enddate>Sys.Date(),Sys.Date(),enddate)))),], aes(x=date, y=porp,label=per))
if (output){
ggsave(paste(Initial,"_EMAProg_PercentPlot.jpeg",sep = ""),device = "jpeg",plot = emaplot.percent,dpi = 300,path = path, height = 8.3, width = 11.7)
message("Percentage Plot Saved to Working Directory")}
#Completion Plot
emaplot.count<-ggplot(data = emamelt.merge, aes(x=date, y=actual, color=Type, group=Type, shape=Type)) +
ggtitle(paste(Initial,"EMA Progress (Count)"))+
theme(plot.title = element_text(hjust = 0.5))+
geom_line()+
ylab("Percentage")+
scale_x_date(name="Date",limits = c(startdate+1,NA) ,date_breaks = "2 days")+
geom_point()+
ggrepel::geom_label_repel(data = emamelt.merge[(which(emamelt.merge$date %in% c(startdate+7,startdate+14,ifelse(enddate>Sys.Date(),Sys.Date(),enddate)))),], aes(x=date, y=actual,label=actual))+
ggrepel::geom_label_repel(data = emamelt.merge[(which(emamelt.merge$date %in% c(startdate+7,startdate+14,ifelse(enddate>Sys.Date(),Sys.Date(),enddate)) & emamelt.merge$Type %in% c("BoD","DoD","Total"))),], aes(x=date, y=expectation,label=expectation),color="black")
if (output){
ggsave(paste(Initial,"_EMAProg_CountPlot.jpeg",sep = ""),device = "jpeg",plot = emaplot.count,dpi = 300,path = path, height = 8.3, width = 11.7)
message("Completion (count) Plot Saved to Working Directory")}
if(codeout){return(list(percentgraph=emaplot.percent,countgraph=emaplot.count))}
} else {message("Skipping Graphing: Input data not compatible, possibly because no entry yet.")}
}
############### EMA 2 RedCap update function:
bsrc.ema.redcapupload<-function(emamelt.merge=NULL,startdate=NULL, enddate=NULL,protocol=protocol.cur,funema=NULL,output=T,ifupload=T,curver="2",idvar="redcapID",...){
#unpack protocol
input.token<-protocol$token
input.uri<-protocol$redcap_uri
rdpath<-protocol$rdpath
protocol.n<-protocol$name
#safe gurad the function:
if (is.null(funema)){funema<-bsrc.getform("ema_session_checklist",grabnewinfo = T, protocol=protocol,... = ...)}
#Pre-check
redcapID<-unique(emamelt.merge[[idvar]])
emamelt.merge$redcapID<-unique(emamelt.merge[[idvar]])
emamelt.merge[[idvar]]<-NULL
originaldata<-funema[which(funema$registration_redcapid==redcapID & funema$redcap_event_name=="ema_arm_1"),c("registration_redcapid","ema_completed___3","ema_completed___2","ema_completed___999","ema_termdate")]
originaldata$ema_completed___999->ninenineninestatus
originaldata$ema_termdate->termdatestatus
originaldata$ema_completed___2->twostatus
originaldata$ema_completed___3->threestatus
emamelt.merge<-emamelt.merge[which(!emamelt.merge$Type %in% c("MB","SetUp")),]
emamelt.merge$check<-NA
#emamelt.merge$check[which(emamelt.merge$date %in% c(startdate+7))]<-"3Days"
if(is.null(emamelt.merge$daysinstudy)){
emamelt.merge$check[which(emamelt.merge$date %in% c(startdate+7))]<-"7Days"
emamelt.merge$check[which(emamelt.merge$date %in% c(startdate+14))]<-"14Days"
emamelt.merge$check[which(emamelt.merge$date %in% c(startdate+21))]<-"21Days"
} else {
emamelt.merge$check[emamelt.merge$daysinstudy %in% c(7,14,21)]<-paste0(emamelt.merge$daysinstudy[emamelt.merge$daysinstudy %in% c(7,14,21)],"Days")
emamelt.merge$daysinstudy<-NULL
}
if (length(which(is.na(emamelt.merge$check))) != length(emamelt.merge$date)) {
test1<-reshape(emamelt.merge[!is.na(emamelt.merge$check),],idvar = "check",timevar = "Type",direction = "wide", v.names = c("actual","per"),drop = c("porp","expectation","diff"))
test1[which(test1$date>=Sys.Date()),grep("actual",names(test1))[1]:length(test1)]<-"NOT FINISH"
test1$date<-as.character(test1$date)
test2<-reshape(test1,idvar = "redcapID",timevar = "check",direction = "wide", v.names = names(test1)[-c(2,3)])
test3<-test2
names(test3)[!grepl("redcapID",names(test3))]<-paste("emapg_",names(test3)[!grepl("redcapID",names(test3))],sep = "")
names(test3)[grepl("redcapID",names(test3))]<-"registration_redcapid"
names(test3)<-tolower(gsub("[.]","_",names(test3)))
if (is.na(termdatestatus) | is.na(ninenineninestatus)){
if(Sys.Date()<enddate+1) {
test3$ema_completed___ip<-1
currentexp<-paste("test3$ema_completed___",curver,"<-0", sep = "")
eval(parse(text=currentexp))
test3$ema_completed___999<-0
test3$redcap_event_name<-"ema_arm_1"
}else {
test3$ema_completed___ip<-0
currentexp<-paste("test3$ema_completed___",curver,"<-1", sep = "")
eval(parse(text=currentexp))
test3$ema_completed___999<-0
test3$ema_termdate<-as.character(enddate)
test3$redcap_event_name<-"ema_arm_1"
test3$prog_emastatus_di<-NA
}
}else {
test3$ema_completed___ip<-0
test3$redcap_event_name<-"ema_arm_1"
test3$prog_emastatus_di<-NA
test3$ema_completed___999<-ninenineninestatus
test3$ema_completed___2<-twostatus
test3$ema_completed___3<-threestatus
}
}else {message(paste("Nothing to upload for",redcapID,"yet, come back after: ", startdate+7))
test3<-data.frame(registration_redcapid=unique(emamelt.merge$redcapID),ema_completed___ip="1")
#names(test3)<-c("registration_redcapid","ema_completed___ip")
test3$redcap_event_name<-"ema_arm_1"
test3$ema_completed___3<-0
test3$ema_completed___999<-0}
if (ifupload) {
result.test3<-REDCapR::redcap_write(test3,token = input.token,redcap_uri = input.uri)
if (result.test3$success) {print("DONE")}}
#if (updatelocaldb) {
#if (length(grep("date",names(test3)))>1){
#test3<-test3[,-grep("date",names(test3))]}
#funbsrc<-bsrc.updatedb(ndf = test3, df=funbsrc)}
if (output) {
return(test3)}
}
################ Get certrain part of EMA data
bsrc.ema.getevent<-function(emadata.raw,pick.input,additional=NA, vers="3") {
stop("This function will be depreciated, and the function call will be replaced by a different function in future updates")
if (missing(emadata.raw)) {
print("Using bsrc.ema.getfile() for data")
emadata.raw<-bsrc.ema.getfile()
}
if (missing(pick.input)) {
pick.input <- readline(prompt = "Please type in BoD, DoD, EoD or MB: ")
}
switch (vers,
"2" = ltrigger<-c("BoD","DoD","EoD","MB"),
"3" = ltrigger<-c("BoD_U","DoD_U","EoD_U","MB")
)
pick<-ltrigger[grep(pick.input,ltrigger)]
test<-emadata.raw
switch (pick,
"DoD" = {pick.w<-c("DoD","rp_")},
"EoD" = {pick.w<-c("EoD","eod_")},
"BoD" = {pick.w<-c("BoD","bod_")},
"DoD_U" = {pick.w<-c("DoD_U","rp_")},
"EoD_U" = {pick.w<-c("EoD_U","eod_")},
"BoD_U" = {pick.w<-c("BoD_U","bod_")},
"MB" = {pick.w<-c("MB","mb_")})
test1<-test[which(test$Survey_Class==pick.w[1]),grep(paste(pick.w[2],additional,'User_Id',sep = '|',collapse = "|"),names(test))]
return(test1)
}
################ Patch the data for emadata.raw and counts for 'em:
bsrc.ema.patch<-function(emadata.raw,vers="3",skipgetevent=F){
if (missing(emadata.raw)){
print("Using bsrc.ema.getfile() for data")
emadata.raw<-bsrc.ema.getfile()}
switch (vers,
"2" = ltrigger<-c("BoD","DoD","EoD","MB"),
"3" = ltrigger<-c("BoD_U","DoD_U","EoD_U","MB")
)
rownames(emadata.raw)<-NULL
emadata.raw<-bsrc.ema.scaletonum(emadata.raw = emadata.raw)
if (!skipgetevent){
dodonly<-bsrc.ema.getevent(emadata.raw = emadata.raw, pick.input = ltrigger[2], vers = vers)
}else{
emadata.raw->dodonly
}
negnumx<-grep(paste("angry","nervous","sad","irritated",sep = "|",collapse = "|"),names(dodonly))
negnum<-names(dodonly)[intersect(negnumx,grep(pattern = "rp_",names(dodonly)))]
negnum<-negnum[!grepl("_rn",negnum)]
dodonly$ifnegative<-rowSums(dodonly[,negnum] >= 2)>0
dodonly$ifintime<-dodonly$rp_time %in% c("Just happened","15 minutes","30 minutes","45 minutes")
emadata.raw$MB_YES<-FALSE
emadata.raw$MB_Timepoint<-NA
emadata.raw$MB_YES[which(dodonly$ifintime & dodonly$ifnegative)]<-TRUE
emadata.raw$MB_Timepoint[which(emadata.raw$MB_YES & emadata.raw$rp_time == "Just happened")]<-4
emadata.raw$MB_Timepoint[which(emadata.raw$MB_YES & emadata.raw$rp_time == "15 minutes")]<-3
emadata.raw$MB_Timepoint[which(emadata.raw$MB_YES & emadata.raw$rp_time == "30 minutes")]<-2
emadata.raw$MB_Timepoint[which(emadata.raw$MB_YES & emadata.raw$rp_time == "45 minutes")]<-1
return(emadata.raw)
}
############### Scale to Num
bsrc.ema.scaletonum<-function(emadata.raw){
if (missing(emadata.raw)){
print("Using bsrc.ema.getfile() for data")
emadata.raw<-bsrc.ema.getfile()}
emadata.nodate<-emadata.raw[,-grep("Date",names(emadata.raw))]
emadata.onlydate<-as.data.frame(emadata.raw[,grep("Date",names(emadata.raw))])
names(emadata.onlydate)<-names(emadata.raw)[grep("Date",names(emadata.raw))]
emadata.nodate[emadata.nodate == "Very Slightly or Not at All"]<-1
emadata.nodate[emadata.nodate == "A Little"]<-2
emadata.nodate[emadata.nodate == "Moderately"]<-3
emadata.nodate[emadata.nodate == "Quite a Bit"]<-4
emadata.nodate[emadata.nodate == "A great deal"]<-5
emadata.nodate[emadata.nodate == ""]<-NA
emadata.nodate[emadata.nodate == "CONDITION_SKIPPED"]<-NA
emadata.nums<-cbind(emadata.nodate,emadata.onlydate)
return(emadata.nums)
}
################################
#PENDING DX TOOL FOR PT
#############################
dnpl.ema.updatevariref<-function(filename=NULL){
if (is.null(filename)){
print("Please choose a file...")
filename<-file.choose()
}
vari<-read.csv(filename)
vari.valuevariname<-as.character(vari$variableName[which(vari$type != "INFORMATION")])
metadata<-list(metadata=vari,valuevariname=vari.valuevariname,updated.date=Sys.Date())
}
#############################
dnpl.ema.procdb<-function(rdpath=ema.data.rdpath,fulldata.ema=NULL,metadata.ema=NULL,...) {
if (is.null(fulldata.ema) & is.null(metadata.ema)) {
if (file.exists(rdpath)) {
envir.load<-invisible(bsrc.attachngrab(rdpath = rdpath,returnas = "envir"))
fulldata.ema<-envir.load$fulldata.ema
metadata.ema<-envir.load$metadata.ema
}
}
#Plug in more pre-processing steps
#info status:
fulldata.ema<-dnpl.ema.infochange(fulldata.ema = fulldata.ema)
#proc data spilt
fulldata.ema<-dnpl.ema.spiltraw(fulldata.ema = fulldata.ema,metadata.ema = metadata.ema,...)
#More stuff (device OS/daysinto the study):
fulldata.ema<-dnpl.ema.addmorestuff(fulldata.ema = fulldata.ema)
#End
assign("fulldata.ema",fulldata.ema,envir=envir.load)
save(list = objects(envir = envir.load),file = rdpath,envir = envir.load)
}
#############################
dnpl.ema.addmorestuff<-function(fulldata.ema) {
fulldata.ema$pdata$DeviceOS<-fulldata.ema$info$DeviceOS[match(fulldata.ema$pdata$redcapID,fulldata.ema$info$RedcapID)]
bodonly<-subset(fulldata.ema$pdata[which(fulldata.ema$pdata$Type=="BoD"),],select = c("date","redcapID","expectation"))
names(bodonly)[grep("expectation",names(bodonly))]<-"daysinstudy"
fulldata.ema$pdata<-merge(fulldata.ema$pdata,bodonly,all = TRUE)
return(fulldata.ema)
}
############################
dnpl.ema.infochange<-function(fulldata.ema=NULL,info_ss=NULL){
if(!is.null(fulldata.ema)){
fulldata.ema$info$status<-"UNKNOWN"
fulldata.ema$info$duration<-fulldata.ema$info$enddate-fulldata.ema$info$startdate
fulldata.ema$info$status[fulldata.ema$info$duration==21]<-"COMPLETED"
fulldata.ema$info$status[fulldata.ema$info$duration>21]<-"EXCESSIVE"
fulldata.ema$info$status[fulldata.ema$info$duration<21]<-"EARLY-TERMINATION"
endtarget<-merge(aggregate(date ~ redcapID + Type,data=fulldata.ema$pdata[which(fulldata.ema$pdata$Type=="Total"),], max),fulldata.ema$pdata,all.x=TRUE)
fulldata.ema$info$completion_rate<-endtarget$per[match(fulldata.ema$info$RedcapID,endtarget$redcapID)]
returnwhat<-fulldata.ema
} else if (!is.null(info_ss)){
message("Function is depreciated for this use.")
}
return(fulldata.ema)
}
############################
dnpl.ema.spiltraw<-function(fulldata.ema=fulldata.ema,metadata.ema=metadata.ema,getmore.u=NULL,base.n=NULL) {
if (is.null(base.n)){
base.n<-c("User_Id","Survey_Submitted_Date","Survey_Submitted_Time","TriggerName")
print(paste("by default, each form will include these variables: ",paste(base.n,collapse = " ;")))
}
genvariname<-c(base.n,getmore.u)
rawdata<-fulldata.ema$raw
proc.e<-fulldata.ema$pdata[which(fulldata.ema$pdata$Type=="BoD"),c("date","redcapID","expectation")]
names(proc.e)<-c("Survey_Submitted_Date","RedcapID","Days")
for (i in 1:length(names(metadata.ema))) {
formname<-names(metadata.ema)[i]
print(paste("Processing '",formname,"'.....",sep = ""))
formvariname<-metadata.ema[[formname]]$valuevariname
proc.a<-rawdata[,c(genvariname,formvariname)]
proc.b<-bsrc.ema.scaletonum(proc.a)
limitlength<-(unique(apply(proc.b, 1, function(x) {length(x)}))[1])-(length(genvariname))
proc.c<-proc.b[which(apply(proc.b, 1, function(x) {length(which(is.na(x)))})<limitlength),]
proc.c$RedcapID<-fulldata.ema$info$RedcapID[match(proc.c$User_Id,fulldata.ema$info$mwuserid)]
proc.c$CompletionRate<-as.numeric(apply(proc.c, 1, function(x) {1-(length(which(is.na(x))) / length(x))}))
proc.f<-merge(proc.c,proc.e,all.x = T, by.x = c("RedcapID","Survey_Submitted_Date"), by.y = c("RedcapID","Survey_Submitted_Date"))
str.e<-paste("fulldata.ema$procdata$",formname,"<-proc.f",sep = "")
eval(parse(text = str.e))
print("done")}
return(fulldata.ema)
}
###########################
########################
### ANALYSIS/GRAPH ###
########################
#############################
if(FALSE){
groupstat<-na.omit(subset(bsocial$data,select = c("registration_redcapid","fudemo_incomelevel")))
ema$fulldata.ema$pdata$income_b<-groupstat$fudemo_incomelevel[match(ema$fulldata.ema$pdata$redcapID,groupstat$registration_redcapid)]
ggplot(data = info_all,aes(x=StartDate,y=MBCount,color=Group)) + geom_point()
info_all$month<-factor(month.name[month(info_all$StartDate)],levels = month.name)
library(lme4)
summary(lm(scale(MBCount)~as.factor(Group)+month+scale(CompletionRate)+as.factor(DeviceOS),data = info_all))
summary(lm(scale(CompletionRate)~as.factor(Group)+month+scale(CompletionRate)+as.factor(DeviceOS),data = info_all))
}
dnpl.ema.missinggraph<-function(df, Typename="Type",path=getwd(),#referenceline=c("horizontal","diagonal")
referenceline="diagonal",
graphictype=c("jitter","gam"),
xa="expectation",ya="actual",by="redcapID",additional=NULL){
colnames(df)[grep(Typename,names(df))]<-"Type"
x.bse<-paste("ggplot(data = df.x, aes(x= ",xa,", y= ",ya,", color = ",by,"))",sep = "")
if (!is.null(referenceline)) {
if (any(referenceline %in% "horizontal")) {
referl.h<-"+ geom_abline(intercept = 50,slope = 0, size=0.8)"
} else {referl.h<-NULL}
if (any(referenceline %in% "diagonal")) {
referl.d<-"+ geom_abline(intercept = 0,slope = 1, size=0.8)"
} else {referl.d<-NULL}
referl<-paste(referl.h,referl.d,collapse = "",sep = " ")
}
if (!is.null(graphictype)) {
funclist<-list()
if (any(graphictype %in% "jitter")) {
funclist[["jitter"]]<-list(name="jitter",call="+ geom_jitter()")
}
if (any(graphictype %in% "gam")) {
funclist[["gam"]]<-list(name="gam",call="+ geom_smooth()")
}
}
for (i in unique(df$Type)) {
targettype=as.character(i)
print(targettype)
df.x<-df[which(df$Type==targettype),]
lapply(funclist,function(x) {
ggsave(filename = paste(paste(targettype,xa,ya,by,x$name,sep = "_"),".jpeg",sep=""),
device = "jpeg",
plot = eval(parse(text = paste(x.bse,
paste("+ ggtitle(paste(targettype,'",x$name,"'))",sep = ""),
referl,
ifelse(is.null(additional),'',paste("+",additional)),
x$call
))),
dpi = 300,path = path, height = 8.3, width = 11.7)
})
}
}
###############################
dnpl.ema.statsbyweek<-function(fulldata.ema=fulldata.ema){
yz<-apply(fulldata.ema$rdata[grep("emapg_per_",names(fulldata.ema$rdata))], 2, function(x) {
x<-na.omit(x)
if (length(agrep("*%",x))>0) {
x<-as.numeric(sapply(strsplit(x,split = " %"),"[[",1))
} else {x<-as.numeric(x)}
summary(na.omit(x))})
#fulldata.ema$pdata$
final<-list()
for (i in 1:length(rownames(yz))) {
y<-yz[i,]
typename<-rownames(yz)[i]
y<-as.data.frame(y)
ls.y<-strsplit(rownames(y),split = "_")
y$type<-sapply(ls.y, "[[",3)
y$time<-sapply(ls.y, "[[",4)
y<-reshape(y,direction = "wide",idvar = "type")
rownames(y)<-y$type
y$type<-NULL
names(y)<-sapply(strsplit(names(y),split = ".", fixed = T),"[[",2)
#y$mean<-apply(y, 1, mean)
#y.ex<-apply(y, 2, mean)
#y.x<-rbind(y,y.ex)
#rownames(y.x)<-c(rownames(y),"rownames")
final[[typename]]<-y
}
return(final)
}
################################
################Ver 2: Intergrated main and redcapupload (Single; Legacy)
bsrc.ema.oneshotupload<-function(filename.e,forceupdate.e=F,ifupload=T,curver.e="2", graphic.e=T){
if (missing(filename.e)) {
print("No file specified, please choose the target file")
filename.c<-file.choose()}
else {filename.e->filename.c}
bsrc.ema.redcapupload(emamelt.merge = bsrc.ema.main(emadata.raw = bsrc.ema.getfile(filename = filename.c), forceupdate.e = forceupdate.e, ifupload = T, graphic = graphic.e),ifupload = T,curver = curver.e)
}
bsrc.ema.procActualData<-function(dfb,metadata.ema){
dfb_sp<-split(dfb,dfb$Survey_Class)
dfb_spa<-lapply(names(dfb_sp),function(xname){
cleanupdf(dfb_sp[[xname]],metadata.ema[[match(tolower(xname),names(metadata.ema))]]$valuevariname)
})
names(dfb_spa)<-names(dfb_sp)
return(dfb_spa)
}
################ Loop:
bsrc.ema.loopit<-function(rdpath.ema=rdpaths$ema,loop.path=NULL, file=NULL,gpath,
graphic=T,updatedata=T,forcerun=F,ifupload.e=T,
local=F,curver.e="3",protocol=protocol.cur,
envir.load=NULL,...) {
message("!!!!!WARNING!!!!!!THIS FUNCTION IS FORMALLY REPLACED BY 'bsrc.ema.update' AND WILL NOT WORK WITH DATABASE!!!!")
Sys.sleep(30)
if(curver.e=="2" & is.null(loop.path)){loop.path<-getwd()}
if(curver.e=="3" & is.null(file)){filename<-file.choose()}
if(missing(gpath)) {
if(exists("ema.graph.path")){
gpath<-ema.graph.path
}else{gpath<-NULL}
}
if(is.null(gpath)){
message("Graphing is turned off because no graphic path provided...")
graphic=FALSE}
run2<-F
run3<-F
skip<-F
outcome.r.temp<-NULL
outcome.temp<-NULL
writetofile<-FALSE
fulldata.ema<-NULL
outcome<-NULL
outcome.r<-NULL
emadata.raw.combo<-NULL
info.combo<-NULL
#subreg<-bsrc.getevent(eventname = "enrollment_arm_1",subreg = T, protocol = protocol,... = ...)
funema<-bsrc.getform(formname = "ema_session_checklist",grabnewinfo = !local, protocol = protocol,... = ...)
subreg<-bsrc.getform(formname = c("record_registration","progress_check"),grabnewinfo = !local, protocol = protocol,... = ...)
protocol$redcap_uri->input.uri
protocol$token->input.token
if (file.exists(rdpath.ema)) {
envir.load<-invisible(bsrc.attachngrab(rdpath = rdpath.ema,returnas = "envir"))
fulldata.ema<-envir.load$fulldata.ema
metadata.ema<-envir.load$metadata.ema
pathsplit<-strsplit(rdpath.ema,split = "/")[[1]]
topath<-paste(paste(pathsplit[-length(pathsplit)],collapse = "/",sep = ""),"Backup","emaloop.backup.rdata",sep = "/")
file.copy(from = rdpath.ema, to = topath, overwrite = T)
message("Backed-up previousely used db, in case it broke...")
outcome<-fulldata.ema$pdata
outcome.r<-fulldata.ema$rdata
emadata.raw.combo<-fulldata.ema$raw
info.combo<-fulldata.ema$info
}else if (is.null(envir.load)) {envir.load<-new.env(parent = emptyenv())}
switch(curver.e,
"2" = {
loop.path->path
temp<-list.files(path,pattern="*.csv")
print("This is to upload and update redcap")
for (i in 1:length(temp)){
print(paste("Now reading file ",i," out of ",length(temp),sep = ""))
filename<-paste(path,temp[i],sep = "/")
emadata.raw<-bsrc.ema.getfile(filename = filename, curver = "2")
output.c<-bsrc.ema.main(emadata.raw = emadata.raw, graphic = graphic, path = gpath,subreg = subreg, funema = funema)
if (!as.character (output.c$info$RedcapID) %in% as.character(info.combo$RedcapID) | forcerun){
output<-output.c$data
startdate<-output.c$info$startdate
enddate<-output.c$info$enddate
output.r<-bsrc.ema.redcapupload(emamelt.merge = output,output = T, ifupload = F,curver = "2",startdate = startdate,enddate = enddate, funema = funema)
info<-output.c$info
if (i==1 & !skip)
{outcome<-output
outcome.r<-output.r
emadata.raw.combo<-emadata.raw
info.combo<-info
}
if (i==1) {
outcome.r.temp<-output.r
outcome.temp<-output}
outcome.r.temp<-merge(outcome.r.temp,output.r,all=T)
outcome.temp<-merge(outcome.temp,output,all=T)
if (output.r$ema_completed___2==1) {
writetofile<-TRUE
outcome<-merge(outcome,output,all=T)
outcome.r<-merge(outcome.r,output.r,all=T)
emadata.raw.combo<-merge(emadata.raw.combo,emadata.raw,all=T)
info.combo<-merge(info.combo,info,all=T)}
output<-NULL
output.r<-NULL
output<-NULL
output.r<-NULL
emadata.raw<-NULL
info<-NULL
}else{print("------SKIPPED; DATA ALREADY IN emadata.all.rdata--------")}
}#END of LOOP
},
"3" = {
message("!!!!!WARNING!!!!!!THIS FUNCTION IS FORMALLY REPLACED BY 'bsrc.ema.update' AND WILL NOT WORK WITH DATABASE!!!!")
emadata.raw<-NULL
emadata.raw<-bsrc.ema.getfile(filename = filename,curver = "3",funema = funema,envir=envir.load)
if (!forcerun & any(unique(emadata.raw$RedcapID) %in% as.character(info.combo$RedcapID))){
completedid<-unique(emadata.raw$RedcapID)[which(unique(emadata.raw$RedcapID) %in% as.character(info.combo$RedcapID))]
emadata.raw<-emadata.raw[which(is.na(match(emadata.raw$RedcapID,completedid))),]
message(paste("Skipped these IDs because they have completed: ",paste(completedid,collapse = ","),sep = ""))
}
outcome.r.temp<-data.frame()
outcome.temp<-data.frame()
for (i in 1:length(unique(emadata.raw$RedcapID))) {
message("!!!!!WARNING!!!!!!THIS FUNCTION IS FORMALLY REPLACED BY 'bsrc.ema.update' AND WILL NOT WORK WITH DATABASE!!!!")
message("##########################")
message(paste("Now processing ",i," out of ",length(unique(emadata.raw$RedcapID)),sep = ""))
message(unique(emadata.raw$RedcapID)[i])
curredcap<-unique(emadata.raw$RedcapID)[i]
currda<-emadata.raw[which(emadata.raw$RedcapID==curredcap),]
rownames(currda)<-NULL
fstatus<-F
output<-NULL
output.r<-NULL
tryCatch({
output.c<-bsrc.ema.main(emadata.raw = currda, graphic = graphic, path = gpath, subreg = subreg, funema = funema)
output<-output.c$data
startdate<-output.c$info$startdate
enddate<-output.c$info$enddate
},error=function(x){
message("EMA MAIN NOT DONE")
message(unique(emadata.raw$RedcapID)[i])
})
tryCatch({
output.r<-bsrc.ema.redcapupload(emamelt.merge = output,output = T, ifupload = F, curver = "3",startdate = startdate,enddate = enddate,funema = funema)
}, error=function(x){
message("REDCAP UPLOAD NOT DONE")
message(unique(emadata.raw$RedcapID)[i])
})
if (!is.null(output) & length(outcome.temp)==0){
outcome.temp<-output}
if (!is.null(output.r) & length(outcome.r.temp)==0) {
outcome.r.temp<-output.r
}
if (!is.null(output)) {
message("MERGING MAIN")
outcome.temp<-merge(outcome.temp,output,all = T)
}
if (!is.null(output.r)) {
message("MERGING REDCAP")
outcome.r.temp<-merge(outcome.r.temp,output.r,all = T)
}
if (!is.null(output.r)) {
if (output.r$ema_completed___3==1 | output.r$ema_completed___999==1) {
writetofile<-TRUE
message("**COMPLETED/TERMINATED**")
message("Adding this person to EMA database")
info<-output.c$info
outcome<-merge(outcome,output,all=T)
outcome.r<-merge(outcome.r,output.r,all=T)
emadata.raw.combo<-merge(emadata.raw.combo,currda,all=T)
info.combo<-merge(info.combo,info,all=T)
currda<-NULL
info<-NULL}}
} #End of Loop
})
outcome<-outcome[which(!outcome$porp %in% c("NaN",NA)),]
outcome.temp<-outcome.temp[which(!outcome.temp$porp %in% c("NaN",NA)),]
if (updatedata & writetofile){
message("Saving back to file...")
fulldata.ema<-list(info=info.combo,pdata=outcome,rdata=outcome.r,raw=emadata.raw.combo,update.date=Sys.Date())
assign("fulldata.ema",fulldata.ema,envir=envir.load)
save(list = objects(envir.load),file = rdpath.ema,envir = envir.load)
dnpl.ema.procdb(rdpath = rdpath.ema)
}
if (ifupload.e) {
if (length(outcome.r.temp$registration_redcapid)>0){
message("Starting to upload updates to RedCap...")
result.outcome.r<-REDCapR::redcap_write(outcome.r.temp,token = input.token,redcap_uri = input.uri)
if (result.outcome.r$success) {message("DONE")} else {message("SOMETHING WENT WRONG")}
}else{message("Nothing to upload...closing down...")}
} else {message("ifupload.e arugement is FALSE, no uploading")}
return(list(main=outcome.temp,redcapupload=outcome.r.temp))
}
#####################
########END##########
#####################
#Construction:
#New orgnization and looping:
#input:
# raw_fpath=file.choose()
# ema_raw=NULL
# protocol=protocol.cur
# emardpath=rdpaths$ema
# ss.graph=T
# graph_path=ema.graph.path
# local=F
# restricData=T
# forceRerun=F
# updateRC=T
# excludeID=c("")
if(FALSE){
#!stucture of new environment:
newenvir_ema<-new.env()
envir_ema$matchdb->newenvir_ema$matchdb #no need to worry about that
newenvir_ema$CompletedData$CompletionRateData<-lapply(completed_sub,function(sx){sx$data})
do.call(rbind,lapply(completed_sub,function(sx){sx$info}))
fulldata.ema<-list(info=info.combo,pdata=outcome,rdata=outcome.r,raw=emadata.raw.combo,update.date=Sys.Date())
metadata.ema<-ema$metadata.ema
ema_raw_old_proc<-envir_ema$fulldata.ema$raw
ema_raw_old_proc<-as.data.frame(apply(ema_raw_old_proc,2,as.character),stringsAsFactors = F)
completed<-bsrc.ema.rawtolist(ema_raw = ema_raw_old_proc, rc_ema = rc_ema, envir_ema = envir_ema)
completed_sub<-lapply(X = completed,FUN = bsrc.ema.singlesubproc,graphic=F,graph_path=graph_path)
info.df<-do.call(rbind,lapply(completed_sub,function(xz){xz$info}))
info.df<-info.df[order(info.df$EndDate),]
#rownames(info.df)<-NULL
completed$`203182`->dfb
}
DecisionNeurosciencePsychopathology/redcap_in_r documentation built on April 13, 2021, 9:46 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions bsrc.ema.loopit bsrc.ema.procActualData bsrc.ema.oneshotupload dnpl.ema.statsbyweek dnpl.ema.missinggraph dnpl.ema.spiltraw dnpl.ema.infochange dnpl.ema.addmorestuff dnpl.ema.procdb dnpl.ema.updatevariref bsrc.ema.scaletonum bsrc.ema.patch bsrc.ema.getevent bsrc.ema.redcapupload bsrc.ema.progress.graph bsrc.ema.singlesubproc bsrc.ema.main bsrc.ema.rawtolist bsrc.ema.getfile bsrc.ema.mwredcapmatch bsrc.ema.update cleanupdf
###############################################################################################################
# ECOLOGIST scripts for EMA related functions #
# #
# bsrc.ema.mwredcapmatch(): Do mw redcap id match and produce a localmatch df, mainly used in bsrc.getfile() #
# bsrc.getfile(): Modify trigger names and add RedCap ID based on matching, mainly used in bsrc.ema.loopit() #
# bsrc.ema.main(): Preprocess single participant and produce a processed completion rate df, #
# mainly used in bsrc.ema.loopit() #
# bsrc.ema.progress.graph(): Graphing function for bsrc.ema.main() #
# bsrc.ema.redcapupload(): Reshape single subject df completion rate df into RedCap upload friendly format, #
# mainly used in bsrc.ema.loopit() #
# bsrc.ema.getevent(): Grab raw data by Survey. This is mainly eliminated, in favor of the new data #
# organization; mainly used in bsrc.ema.patch() #
# bsrc.ema.patch(): Patch raw data to add mircoburst related variables for better processing, #
# mainly used in bsrc.ema.main() #
# bsrc.ema.scaletonum(): Change survey answer to numeric value, mainly used in bsrc.ema.patch() #
# bsrc.ema.loopit(): Wrapping function for the data preprocessing pipeline, it perform the following: #
# 1) Grab the raw data from file system and transform it to data frame #
# a) For Ver.2, loop around all data files #
# b) For Ver.3, separate raw data by subject and loop around subjects who are not in #
# database. #
# 2) Push raw through bsrc.ema.main() and then bsrc.ema.redcapupload() #
# a) However, will not upload right away #
# 3) When completed, merge new participant who had now completed to previous data; and #
# merge all the incomplete/in progress participant's redcap data #
# 4) Upload the redcap data to redcap #
# 5) Assign data back into environment, then save back to file #
# 6) Allow additional pre-processing to be done with dnpl.ema.procdb() #
# dnpl.ema.updatevariref(): Very unhelpful function used in creating metadata for EMA database, rarely used #
# dnpl.ema.procdb(): Wrapper for additional preprocessing for the data, used in bsrc.ema.loopit() #
# dnpl.ema.infochange(): Reword info dataframe that's generated by bsrc.ema.main() #
# dnpl.ema.spiltraw(): Spilt raw data into different data frames #
# dnpl.ema.missinggraph(): Graphic representation of missingness by subject #
# dnpl.ema.meanbyweek(): Calculate mean completion rate by week #
# #
# NO LONGER USEFUL REALLY: #
# bsrc.ema.oneshotupload(): Once a upon time...there were multiple user data to process at once. Tis the loop #
# #
# Legacy time convertion #
# subactivity$fordate <- as.Date(strptime(subactivity$For.Time, '%d/%m/%Y %H:%M:%S')) #
# #
###############################################################################################################
####Utilities
cleanupdf<-function(dfx,req.varinames=NULL){
dfx<-dfx[which(apply(dfx,2,function(s){any(!is.na(s))}))]
if(!is.null(req.varinames)){
dfx[req.varinames[which(!req.varinames %in% names(dfx))]]<-NA
}
return(dfx)
}
################Main Wrapper Function:
bsrc.ema.update<-function(raw_fpath=file.choose(),ema_raw=NULL,protocol=protocol.cur,defaultchoice=NULL,
emardpath=rdpaths$ema,ss.graph=T,graph_path=ema.graph.path,metadata.ema=NULL,
local=F,restrictData=T, forceRerun=F, updateRC=T, updateDB=T,excludeID=c("")){
#Initialization:
if(is.null(ema_raw)){ema_raw<-read.csv(raw_fpath,stringsAsFactors = F)}
rc_ema<-bsrc.getform(formname = c("record_registration","ema_session_checklist"),grabnewinfo = !local, protocol = protocol)
if(file.exists(emardpath)){
envir_ema<-bsrc.attachngrab(emardpath)
#envir_ema<-bsrc.attachngrab("ema_test.rdata")
if(is.null(metadata.ema)){metadata.ema <- envir_ema$metadata.ema}
} else { if(is.null(metadata.ema)) {stop("This function can't generate metadata object, will terminate if not provided.")}
envir_ema<-as.environment(list(fulldata.ema=list(raw_data=list(),proc_data=list(),progress_data=list(),info=data.frame(stringsAsFactors = F)),
metadata.ema=metadata.ema))
}
completed_raw<-envir_ema$fulldata.ema$raw_data
completed_proc<-envir_ema$fulldata.ema$proc_data
completed_prog<-envir_ema$fulldata.ema$progress_data
completed_info<-envir_ema$fulldata.ema$info
finished_ID<-as.character(completed_info$RedcapID[which(completed_info$Status %in% c("COMPLETED","EARLY-TERMINATION"))])
finished_ID<-finished_ID[finished_ID %in% names(completed_proc)]
#
# ema_raw_old_proc<-envir_ema$fulldata.ema$raw
# ema_raw_old_proc<-as.data.frame(apply(ema_raw_old_proc,2,as.character),stringsAsFactors = F)
# completed<-bsrc.ema.rawtolist(ema_raw = ema_raw_old_proc, rc_ema = rc_ema, envir_ema = envir_ema)
#
ema_split<-bsrc.ema.rawtolist(ema_raw = ema_raw, rc_ema = rc_ema, envir_ema = envir_ema,protocol=protocol,defaultchoice=defaultchoice)
matchdb <- envir_ema$matchdb
# new_info[which(new_info$CompletionRate < 0.1),]
#
if(!forceRerun){
message("These folks had completed, no need to reprocess: ", paste(finished_ID,collapse = " "))
ema_split_filter<-ema_split[!names(ema_split) %in% finished_ID]
} else {ema_split_filter<-ema_split}
#We replace old raw and get new ones here:
completed_raw<-completed_raw[which(!names(completed_raw) %in% names(ema_split_filter))]
new_raw<-c(completed_raw,ema_split_filter)
# completed_sub<-lapply(X = completed,FUN = bsrc.ema.singlesubproc,graphic=F,graph_path=graph_path)
pData_allsub<-lapply(X = ema_split_filter,FUN = bsrc.ema.singlesubproc,graphic=ss.graph,graph_path=graph_path,restrictData=restrictData)
# completed_prog<-lapply(completed_sub,function(xz){xz$data})
ema_progress_n<-lapply(pData_allsub,function(xz){xz$data})
completed_prog<-completed_prog[which(!names(completed_prog) %in% names(ema_progress_n))]
new_progress<-c(completed_prog,ema_progress_n)
# completed_info<-do.call(rbind,lapply(completed_sub,function(xz){xz$info}))
# completed_info<-completed_info[order(completed_info$EndDate,decreasing = T),]
ninfo.df<-do.call(rbind,lapply(pData_allsub,function(xz){xz$info}))
completed_info<-completed_info[which(!as.character(completed_info$RedcapID) %in% as.character(ninfo.df$RedcapID) ),]
new_info<-rbind(completed_info,ninfo.df)
new_info<-new_info[order(new_info$EndDate,decreasing = T),]
#completed_proc<-lapply(completed_raw,bsrc.ema.procActualData,metadata.ema=metadata.ema)
ema_proc_n<-lapply(ema_split_filter,bsrc.ema.procActualData,metadata.ema=metadata.ema)
completed_proc<-completed_proc[which(!names(completed_proc) %in% names(ema_proc_n))]
new_proc<-c(completed_proc,ema_proc_n)
ema_rc_all<-ProcApply(pData_allsub,function(ema_lss){
#message(ema_lss$info$RedcapID)
if(!is.null(ema_lss$data)){
bsrc.ema.redcapupload(emamelt.merge = ema_lss$data,startdate = (ema_lss$info$StartDate)-1,
enddate = ema_lss$info$EndDate,funema = rc_ema,output = T,
ifupload = F,curver = "3",idvar = "RedCapID")
} else {return(NULL)}
})$df
#return(ema_rc_all)
if(is.data.frame(ema_rc_all) && nrow(ema_rc_all)>0){
ema_rc_all<-as.data.frame(apply(ema_rc_all[!is.na(ema_rc_all$registration_redcapid),],2,as.character))
if(updateRC){
print(ema_rc_all)
result.rc_all<-REDCapR::redcap_write(ema_rc_all,token = protocol$token,redcap_uri = protocol$redcap_uri)
if (result.rc_all$success) {message("Updated these IDs: ",paste(ema_rc_all$registration_redcapid,collapse = " "))}
} else {message("RedCap Update failed.")}
} else {
message("Nothing to update, go away.")
}
if(updateDB) {
fulldata.ema<-list(info=new_info,progress_data=new_progress,proc_data=new_proc,raw_data=new_raw,update.date=Sys.Date(),ver.tag=4)
save(list=c("metadata.ema","fulldata.ema","matchdb"),file = emardpath)
}
message("DONE.")
}
#################
#EMA 3 Exclusive Functions; match metricwire user ID to redcap ID
bsrc.ema.mwredcapmatch<-function(ema3.raw=NULL,funema=NULL,envir=NULL,defaultchoice=NULL,...) {
ema3<-ema3.raw
ema3$ema_id[which(ema3$ema_id=="")]<-NA
ema3a<-ema3[!duplicated(ema3[c("User_Id","ema_id")]),c("User_Id","ema_id")]
ema3a<-ema3a[order(ema3a$ema_id),]
localmatch<-ema3a[!(duplicated(ema3a$User_Id) & is.na(ema3a$ema_id)),]
names(localmatch)<-c("ema_studyidentifier","registration_redcapid")
localmatch<-localmatch[!duplicated(localmatch),]
localmatch$registration_redcapid[is.na(localmatch$registration_redcapid)]<-"UNKNOWN"
localmatch$origin <- "Source"
if(is.null(funema)) {funema<-bsrc.getform(formname = "ema_session_checklist",grabnewinfo = T,...)}
rcmatch<-na.omit(funema[c("ema_studyidentifier","registration_redcapid")])
rcmatch$origin <- "RedCap"
if (!is.null(envir) & exists("matchdb",envir = envir)){matchdb<-get("matchdb",envir = envir)}else{matchdb<-data.frame(ema_studyidentifier=NA,registration_redcapid=NA)}
matchdb$origin <- "Existing"
summatch<-rbind(localmatch,rcmatch,matchdb)
summatch_sp<-split(summatch,summatch$ema_studyidentifier)
postmatch<-lapply(summatch_sp,function(dbax){
#print(unique(dbax$ema_studyidentifier))
if(length(unique(dbax$registration_redcapid))>1) {
if("Existing" %in% dbax$origin && "RedCap" %in% dbax$origin) {
if(dbax$registration_redcapid[which(dbax$origin == "Existing")] == dbax$registration_redcapid[which(dbax$origin == "RedCap")] ) {
return(dbax[which(dbax$origin=="Existing"),c("ema_studyidentifier","registration_redcapid")])
}
}
message(paste("This MetricWire Identifier: [",unique(dbax$ema_studyidentifier),"] has inconsistant IDs:") )
message(paste(dbax$registration_redcapid,dbax$origin,sep = " from ",collapse = " , ") )
if(is.null(defaultchoice)){
whichonetoget<-readline(prompt = "Please type in the source of the actual ID, type 'SKIP' to ignore this person: ")
} else {message("The default choice was set to: ", defaultchoice,". No need to ask.")
whichonetoget <- defaultchoice
}
if(whichonetoget == "SKIP") {return(NULL)} else {return(dbax[which(dbax$origin==whichonetoget),c("ema_studyidentifier","registration_redcapid")])}
} else {
return(unique(dbax[c("ema_studyidentifier","registration_redcapid")]))
}
})
postmatch <- do.call(rbind,postmatch)
row.names(postmatch)<-NULL
assign("matchdb",postmatch,envir = envir)
return(postmatch)
#
}
############### General Get File
bsrc.ema.getfile<-function(filename, curver="2",funema=NULL,envir=NULL,...){
if (missing(filename)) {
message("No file specified, please choose the target file")
filename<-file.choose()
}
tryCatch({
emadata.raw<- read.csv(filename, stringsAsFactors=FALSE)
}, error=function(x){
}) #find function
run2<-F
run3<-F
switch(curver, "2" = {run2<-T}, "3" = {run3<-T})
if (run2){
if(is.null(funema)) {funema<-bsrc.getform(formname = "ema_session_checklist",grabnewinfo = T)}
variname<-read.csv("variname.csv") #find variname
variname<-as.character(variname$variname)
names(emadata.raw)<-as.list(variname)
mwmatch<-data.frame(funema$registration_redcapid,funema$ema_studyidentifier)
names(mwmatch)<-c('registration_redcapid','ema_studyidentifier')
emadata.raw$RedcapID<-mwmatch$registration_redcapid[match(emadata.raw$User_Id,mwmatch$`ema_studyidentifier`)]
RedcapID<-unique(emadata.raw$RedcapID)
emadata.raw$Survey_Class<-emadata.raw$TriggerName
emadata.raw$Survey_Class[which(!emadata.raw$Survey_Class %in% c("BoD","EoD","DoD"))]<-"MB"
emadata.raw$Survey_Class<-as.character(emadata.raw$Survey_Class)
d<-as.Date(emadata.raw$Survey_Submitted_Date,format = "%d/%m/%Y")
emadata.raw$Survey_Submitted_Date<-as.Date(ifelse(d < "2012-12-31", format(d, "20%y-%m-%d"), format(d)))
d<-as.Date(emadata.raw$Survey_Started_Date,format = "%d/%m/%Y")
emadata.raw$Survey_Started_Date<-as.Date(ifelse(d < "2012-12-31", format(d, "20%y-%m-%d"), format(d)))
d<-as.Date(emadata.raw$TriggerDate,format = "%d/%m/%Y")
emadata.raw$TriggerDate<-as.Date(ifelse(d < "2012-12-31", format(d, "20%y-%m-%d"), format(d)))}
if(run3) {
if(is.null(funema)) {funema<-bsrc.getform(formname = "ema_session_checklist",grabnewinfo = T)}
emadata.raw<-emadata.raw[which(emadata.raw$User_Id!=""),]
emadata.raw$Survey_Class<-emadata.raw$TriggerName
emadata.raw$Survey_Class[which(emadata.raw$Survey_Class %in% c("BoD_U"))]<-"BoD"
emadata.raw$Survey_Class[which(emadata.raw$Survey_Class %in% c("DoD_U"))]<-"DoD"
emadata.raw$Survey_Class[which(emadata.raw$Survey_Class %in% c("EoD_U"))]<-"EoD"
emadata.raw$Survey_Class[which(emadata.raw$Survey_Class %in% c("SetUp"))]<-"SetUp"
emadata.raw$Survey_Class[which(!emadata.raw$Survey_Class %in% c("BoD","EoD","DoD","SetUp",""))]<-"MB"
idmatch<-bsrc.ema.mwredcapmatch(emadata.raw,funema=funema,envir=envir,...)
emadata.raw$RedcapID<-idmatch$registration_redcapid[match(emadata.raw$User_Id, idmatch$ema_studyidentifier)]
lRedcapID<-unique(emadata.raw$RedcapID)
emadata.raw$Survey_Started_Date<-as.Date(emadata.raw$Survey_Started_Date)
emadata.raw$Survey_Submitted_Date<-as.Date(emadata.raw$Survey_Submitted_Date)
emadata.raw$TriggerDate<-as.Date(emadata.raw$TriggerDate)
}
return(emadata.raw)
}
###############Updated Get file function for list:
bsrc.ema.rawtolist<-function(ema_raw=NULL,rc_ema=NULL,envir_ema=NULL,protocol=protocol,...){
message("bsrc.ema.rawtolist only works with data collected post version 3a update. Previous Data please manually laod them as list and rbind.")
#Clean Up
ema_raw<-ema_raw[which(ema_raw$User_Id!=""),]
ema_raw[ema_raw==""]<-NA
ema_raw[grep("Date",names(ema_raw))]<-as.data.frame(lapply(ema_raw[grep("Date",names(ema_raw))],as.Date))
ema_raw$Survey_Class<-gsub("_U","",ema_raw$TriggerName)
ema_raw$Survey_Class[which(!ema_raw$Survey_Class %in% c("BoD","EoD","DoD","SetUp",""))]<-"MB"
ema_idmatch<-bsrc.ema.mwredcapmatch(ema3.raw = ema_raw,funema = rc_ema,envir = envir_ema,...)
ema_raw<-bsrc.ema.scaletonum(ema_raw)
#Get Info From REDCAP
ema_raw$RedcapID<-ema_idmatch$registration_redcapid[match(x = ema_raw$User_Id,table = ema_idmatch$ema_studyidentifier)]
ema_raw<-ema_raw[ema_raw$RedcapID!="REMOVE",]
ema_raw<-ema_raw[which(ema_raw$User_Id %in% ema_idmatch$ema_studyidentifier),]
ema_raw$Initial<-rc_ema$registration_initials[match(x = ema_raw$RedcapID,table = rc_ema$registration_redcapid)]
ema_raw$Group<-rc_ema$registration_group[match(x = ema_raw$RedcapID,table = rc_ema$registration_redcapid)]
group_valuemap<-bsrc.getchoicemapping(variablenames = "registration_group",protocol = protocol)
ema_raw$Group<-plyr::mapvalues(ema_raw$Group,from = group_valuemap$choice.code,to = group_valuemap$choice.string,warn_missing = F)
ema_raw$TermDate<-rc_ema[rc_ema$redcap_event_name=="ema_arm_1",]$ema_termdate[match(x = ema_raw$RedcapID,table = rc_ema[rc_ema$redcap_event_name=="ema_arm_1",]$registration_redcapid)]
ema_raw$SetUpDate<-rc_ema[rc_ema$redcap_event_name=="ema_arm_1",]$ema_setuptime[match(x = ema_raw$RedcapID,table = rc_ema[rc_ema$redcap_event_name=="ema_arm_1",]$registration_redcapid)]
#Proc Date Time
ema_raw<-bsrc.ema.patch(emadata.raw = ema_raw,vers = "2",skipgetevent = T)
ema_raw$DateTime<-strptime(paste(ema_raw$Survey_Submitted_Date,ema_raw$Survey_Submitted_Time,sep = " "),format = "%Y-%m-%d %H:%M")
ema_raw<-ema_raw[order(ema_raw$RedcapID),]
ema_split<-split(ema_raw,ema_raw$RedcapID)
names(ema_split)->ls_rcid
return(ema_split)
}
############### EMA2 Main function:
##### urrently hard fixed for EMA 3; new main function needed:
bsrc.ema.main<-function(emadata.raw,path=NULL,graphic=T, gprint=T,subreg=NULL,funema=NULL,protocol=protocol.cur,...){
message("BE AWARE! THIS FUNCTION IS GETTING DEPRECIATED AND A NEW FUNCTION WILL TAKE ITS PLACE SOON.")
if (missing(emadata.raw)){
print("Using bsrc.ema.getfile() for data")
emadata.raw<-bsrc.ema.getfile(curver = "2")
}
if (is.null(subreg)){
subreg<-bsrc.getevent(eventname = "enrollment_arm_1",subreg = T,... = ...)
}
#Require a safeguard of the emadata.raw because the SetUp might bring up the start date earlier than actual:
emadata.raw[which(emadata.raw$Survey_Class %in% c("BoD","EoD","DoD","MB")),]->emadata.raw
#MAKE SURE TO CHECK REDCAP
#Here is where you can do multiple ID processing loop: However, it might not be even useful bc individual files
#Currently take out nas, should only be one item:
RedcapID<-as.character(unique(emadata.raw$RedcapID))
print(RedcapID)
Initial<-as.character(unique(subreg$registration_initials[match(RedcapID,subreg$registration_redcapid)]))
DeviceOS<-as.character(unique(emadata.raw$DeviceOS))
if ("J WOO" %in% Initial) {
RedcapID<-as.character(RedcapID[1])
Initial<-as.character(Initial[1])
DeviceOS<-as.character(emadata.raw$DeviceOS[1])
}
if (length(DeviceOS)>1) {
DeviceOS<-paste(DeviceOS,collapse = "/")
}
if (length(RedcapID)>1){stop("ema.main() can only process only 1 ID data at a time, please filter")}
mwuserid<-as.character(unique(emadata.raw$User_Id[which(emadata.raw$RedcapID==RedcapID)]))
#Patch the data
tryCatch({
emadata.raw<-bsrc.ema.patch(emadata.raw = emadata.raw,vers = "2")},error=function(e) {})
#Read EMA Data:
table.emadata<-data.table::data.table(emadata.raw$RedcapID,emadata.raw$Survey_Submitted_Date,emadata.raw$Survey_Class)
names(table.emadata)<-c("redcapID","date","Type")
table.emadata<-table.emadata[order(table.emadata$Type,table.emadata$date),]
table.emadata[,count:=seq_len(.N), by=Type]
table.emadata[table.emadata$Type=="MB",count:=seq_len(.N), by=date]
table.emadata<-na.omit(table.emadata)
#table.emadata<-table.emadata[which(table.emadata$Type %in% c("DoD","BoD","EoD"))]
table.emadata$redcapID<-as.character(table.emadata$redcapID)
#Safe guard the function from god damn health controls who don't get any negative interaction whatsoever.
if (!any(table.emadata$Type=='MB')) {
table.emadata[1,]->temp
temp$Type<-"MB"
temp$count<-0
table.emadata<-rbind(table.emadata,temp)
emadata.raw$MBYES<-FALSE
}
if (!any(table.emadata$Type=='BoD')) {
table.emadata[1,]->temp
temp$Type<-"BoD"
temp$count<-0
table.emadata<-rbind(table.emadata,temp)
}
if (!any(table.emadata$Type=='DoD')) {
table.emadata[1,]->temp
temp$Type<-"DoD"
temp$count<-0
table.emadata<-rbind(table.emadata,temp)
}
if (!any(table.emadata$Type=='EoD')) {
table.emadata[1,]->temp
temp$Type<-"EoD"
temp$count<-0
table.emadata<-rbind(table.emadata,temp)
}
#Aggregate Total:
emadata<-aggregate(table.emadata,FUN = max,by=list(interaction(table.emadata$date,table.emadata$Type)))
emadata$Group.1<-NULL
emadata<-reshape(emadata,idvar = "date",timevar = "Type",direction = "wide", v.names = c("count"))
emadata<-emadata[order(emadata$date),]
names(emadata)<-c("redcapID","date","BoD","DoD","EoD","MB")
emadata$MB[which(is.na(emadata$MB))]<-0
emadata<-zoo::na.locf(emadata,na.rm=F)
emadata$date<-as.Date(emadata$date)
emadata[is.na(emadata)]<-0
emadata$Total<-as.numeric(emadata$BoD)+as.numeric(emadata$DoD)+as.numeric(emadata$EoD)
#Generate Expectation Grid:
lengthofema<-21
startdate<-as.Date(funema$ema_setuptime[which(funema$registration_redcapid %in% RedcapID & funema$ema_setuptime!="")])
enddate<-startdate+lengthofema
emaseqdate<-seq.Date(from=startdate,to=enddate,by="days")
emaseq.one<-seq(from=0,to=lengthofema,length.out = length(emaseqdate))
emaseq.six<-seq(from=0,to=(6*lengthofema),length.out = length(emaseqdate))
emaseq.total<-seq(from=0,to=(8*lengthofema),length.out = length(emaseqdate))
ematotal.donly<-as.data.frame(emaseqdate)
names(ematotal.donly)<-c("date")
ematotal<-ematotal.donly
ematotal$BoD<-emaseq.one
ematotal$EoD<-emaseq.one
ematotal$DoD<-emaseq.six
#Replace enddate to termination if earlier than expected (def could do better here)
terminationdate<-as.Date(funema$ema_termdate[which(funema$registration_redcapid==RedcapID & funema$ema_termdate!="")])
if (length(terminationdate)>0){
if ((terminationdate-1) < enddate){enddate<-terminationdate}
if ((terminationdate-1) > enddate){
message("THIS PERSON HAS DATA PASS 21 DAYS SINCE START DATE")
enddate<-terminationdate
}
}
#basic info
info<-data.frame(RedcapID,Initial,startdate,enddate,mwuserid,DeviceOS)
if (any(emadata.raw$MBYES)) {
mbonly<-data.table::as.data.table(emadata.raw[which(emadata.raw$MBYES),c("Survey_Submitted_Date","MBCount")])
mbonly<-mbonly[, sum(MBCount), by = Survey_Submitted_Date]
names(mbonly)<-c("date","MB")
ematotal<-merge(ematotal,mbonly,all=T)
ematotal$MB[which(is.na(ematotal$MB))]<-0
} else {ematotal$MB<-0}
ematotal$Total<-as.numeric(ematotal$BoD)+as.numeric(ematotal$DoD)+as.numeric(ematotal$EoD)
ematotal.melt<-reshape2::melt(ematotal,id.var='date',variable.name="Type",value.name="expectation")
#melt data
emadata.full<-merge(ematotal.donly,emadata,all = T)
emadata.full<-zoo::na.locf(emadata.full)
emadata.full.melt<-reshape2::melt(emadata.full,id.var=c("redcapID","date"), measure.vars=c("BoD","DoD","EoD","Total","MB"),variable.name="Type",value.name="actual")
emadata.full.melt$date<-as.Date(emadata.full.melt$date)
#New Merge
emamelt.merge<-merge(emadata.full.melt,ematotal.melt,all=T)
emamelt.merge<-emamelt.merge[which(!emamelt.merge$date==startdate),] #Take out startdate
emamelt.merge<-emamelt.merge[which(!emamelt.merge$date>ifelse(enddate>Sys.Date(),Sys.Date(),enddate)),]
emamelt.merge$actual<-as.numeric(emamelt.merge$actual)
emamelt.merge$expectation<-as.numeric(emamelt.merge$expectation)
emamelt.merge$diff<-emamelt.merge$actual - emamelt.merge$expectation
emamelt.merge$porp<-round(emamelt.merge$actual / emamelt.merge$expectation *100,2)
emamelt.merge$per<-paste(emamelt.merge$porp, "%")
emamelt.merge$Type<-as.character(emamelt.merge$Type)
if (graphic){
bsrc.ema.progress.graph(emamelt.merge = emamelt.merge, path = path, startdate = startdate, enddate = enddate, output = gprint, Initial = Initial)
#End Graphic
}
return(list(data=emamelt.merge,info=info))
}
###############Universal EMA Main function: Single Subject:
bsrc.ema.singlesubproc<-function(ema_ss=NULL,graphic=T,graph_path=ema.graph.path,restrictData=F){
tryCatch({
if(is.null(graph_path)){graphic<-F}
message("")
message("##############")
message("Processing participant...ID: [",unique(ema_ss$RedcapID),"]...Initial: [",unique(ema_ss$Initial),"]")
ema_ss<-ema_ss[order(ema_ss$Survey_Class),]
ema_ss_s<-split(ema_ss,ema_ss$Survey_Class)
#Get the SetUp
if(!is.null(ema_ss$ema_waketime_u)){
setup_ema<-ema_ss[ema_ss$DateTime==max(ema_ss$DateTime[!is.na(ema_ss$ema_waketime_u)]) & !is.na(ema_ss$ema_waketime_u),
c("RedcapID","ema_startdate","ema_waketime_u","ema_bedtime_u")]
names(setup_ema)<-c("RedcapID","StartDate","WakeTime","BedTime")
}else{
setup_ema<-data.frame()
}
#Get the SetUp for version 2
if(nrow(setup_ema)<1){
message("This is probably a version 2 participant...we have to make it up on the fly!")
setup_ema<-data.frame(RedcapID=unique(ema_ss$RedcapID),
StartDate=unique(as.Date(ema_ss$SetUpDate))+1,
WakeTime="01:00",BedTime="23:59",stringsAsFactors = F)
}
#Do correction:
if(setup_ema$StartDate!=unique(as.Date(ema_ss$SetUpDate))+1){
message("This person's SetUp date is incongruent with their redcap setup date. Will use the redcap one.")
setup_ema$StartDate<-unique(as.Date(ema_ss$SetUpDate))+1
}
seqDate_og<-seq.Date(from = as.Date(setup_ema$StartDate),to = as.Date(setup_ema$StartDate)+20,by = "days")
#Check for outside of the window:
minDateTime<-strptime(paste(min(seqDate_og),setup_ema$WakeTime,sep = " "),format = "%Y-%m-%d %H:%M")
maxDateTime<-(strptime(paste(max(seqDate_og),"23:00",sep = " "),format = "%Y-%m-%d %H:%M")+12*60*60)
logicDateTime<-dplyr::between(as.numeric(ema_ss$DateTime),left = as.numeric(minDateTime),right = as.numeric(maxDateTime)) | ema_ss$Survey_Class=="SetUp"
if(any(!logicDateTime)){
message("This subject has data outside of the 21 days window.")
if(restrictData) {
message("restrictData argument is on, therefore will omit any data outside of the 21 days window! But we will keep the raw data.")
} else {
message("restrictData argument is off, will keep all data.")
seqDate_og<-unique(c(unique(ema_ss[ema_ss$Survey_Class!="SetUp",]$Survey_Submitted_Date)[!unique(ema_ss[ema_ss$Survey_Class!="SetUp",]$Survey_Submitted_Date) %in% seqDate_og],seqDate_og))
}
}
if(!is.na(unique(ema_ss$TermDate))){seqDate_og<-seqDate_og[seqDate_og<=as.Date(unique(ema_ss$TermDate))]}
seqDate<-seqDate_og[seqDate_og<as.Date(Sys.Date())]
message("Days in the study: [",length(seqDate),"]")
#Didn't use lapply because accumulation complications;
lpData<-list()
for(inj in 1:length(seqDate)) {
#if(inj>0){
xdate<-seqDate[[inj]]
todayls<-lapply(ema_ss_s,function(ss_x){
StartDateTime<-strptime(paste(xdate,setup_ema$WakeTime,sep = " "),format = "%Y-%m-%d %H:%M")
EndDateTime<-(strptime(paste(xdate,setup_ema$BedTime,sep = " "),format = "%Y-%m-%d %H:%M")+2*60*60)
if(as.numeric(EndDateTime) < as.numeric(StartDateTime)) {EndDateTime <- EndDateTime+(24*60*60)}
dfx_dj<-ss_x[which(dplyr::between(x = as.numeric(ss_x$DateTime),
left = as.numeric(StartDateTime),
right = as.numeric(EndDateTime))),]
})
todayls$SetUp<-NULL
expectls<-list(BoD=1,EoD=1,DoD=6,MB=sum(todayls$DoD$MB_Timepoint,na.rm = T))
expectls$Total<-sum(unlist(expectls[c("BoD","DoD","EoD")]),na.rm = T)
actual<-lapply(todayls,nrow)
actual$Total<-sum(unlist(actual[c("BoD","DoD","EoD")]),na.rm = T)
finaldf<-do.call(rbind,lapply(c(names(todayls),"Total"),function(gx){
if(inj>1){
pdfx<-lpData[[inj-1]]
init_actual<-pdfx$actual[pdfx$Type==gx]
init_expect<-pdfx$expectation[pdfx$Type==gx]} else {
init_actual<-0
init_expect<-0}
data.frame(Type=gx,actual=(actual[[gx]]+init_actual),expectation=(expectls[[gx]]+init_expect))
}))
finaldf$date<-xdate
finaldf$daysinstudy<-as.numeric(as.Date(xdate)-(as.Date(setup_ema$StartDate)-1))
lpData[[inj]]<-finaldf
#}
}
pData<-do.call(rbind,lpData)
rownames(pData)<-NULL
pData<-pData[which(!(pData$actual==0 & pData$expectation==0)),]
pData$RedCapID<-unique(ema_ss$RedcapID)
pData$diff<-pData$actual - pData$expectation
pData$porp<-pData$actual / pData$expectation
pData$per <-paste0(round(pData$porp*100,2)," %")
info_ss<-data.frame(RedcapID=unique(ema_ss$RedcapID),Initial=unique(ema_ss$Initial), Group=unique(ema_ss$Group),
StartDate=min(seqDate_og),EndDate=max(seqDate_og),MWUserID=paste(unique(ema_ss$User_Id),collapse = "/"),
DeviceOS=paste(unique(ema_ss$DeviceOS),collapse = "/"))
info_ss$Status<-"UNKNOWN"
info_ss$Status[info_ss$StartDate<=Sys.Date()]<-"IN-PROGRESS"
info_ss$Status[info_ss$StartDate>Sys.Date()]<-"HAVEN'T STARTED"
info_ss$Status[info_ss$EndDate<Sys.Date() & length(seqDate)==21]<-"COMPLETED"
info_ss$Status[info_ss$EndDate<Sys.Date() & length(seqDate)<21]<-"EARLY-TERMINATION"
info_ss$Status[info_ss$EndDate<Sys.Date() & length(seqDate)>21]<-"EXCESSIVE"
info_ss$Duration<-length(seqDate)
if(is.data.frame(pData) && nrow(pData)>0){
if (graphic){
bsrc.ema.progress.graph(emamelt.merge = pData, path = graph_path, startdate = min(seqDate_og), enddate = max(seqDate_og),
output = T, Initial = unique(ema_ss$Initial))
}
info_ss$CompletionRate<-pData$porp[pData$Type=="Total" & (pData$daysinstudy==max(pData$daysinstudy))]
if(any(pData$Type=="MB")){
info_ss$MBCount<-pData$expectation[pData$Type=="MB" & (pData$daysinstudy==max(pData$daysinstudy))]
info_ss$MBProp<-pData$porp[pData$Type=="MB" & (pData$daysinstudy==max(pData$daysinstudy))]
} else {
info_ss$MBCount<-0
info_ss$MBProp<-NA
}
} else {
message("No data yet. Skipping")
pData<-NULL
info_ss$CompletionRate<-NA
info_ss$MBCount<-0
info_ss$MBProp<-NA
}
message("#####DONE#####")
message("")
return(list(data=pData,info=info_ss))
},error=function(e){message(e)})
}
#########Graphing function:
bsrc.ema.progress.graph<-function(emamelt.merge=NULL, path = getwd(), startdate=NULL,enddate=NULL, output=T, codeout=F,Initial=NULL,...) {
require('ggplot2')
#Safe guard the function:
if(is.data.frame(emamelt.merge) && nrow(emamelt.merge)>0){
#Safe guard the plot:
emamelt.merge<-emamelt.merge[emamelt.merge$Type!="MB",]
#Percentage Plot
emaplot.percent<-ggplot(data = emamelt.merge, aes(x=date, y=porp, group=Type, shape=Type, color=Type)) +
ggtitle(paste(Initial,"EMA Progress (Percentage)"))+
theme(plot.title = element_text(hjust = 0.5))+
geom_line()+
ylab("Percentage")+
scale_x_date(name="Date",limits = c(startdate+1,NA) ,date_breaks = "2 days")+
geom_point()+
ggrepel::geom_label_repel(data = emamelt.merge[(which(emamelt.merge$date %in% c(startdate+7,startdate+14,ifelse(enddate>Sys.Date(),Sys.Date(),enddate)))),], aes(x=date, y=porp,label=per))
if (output){
ggsave(paste(Initial,"_EMAProg_PercentPlot.jpeg",sep = ""),device = "jpeg",plot = emaplot.percent,dpi = 300,path = path, height = 8.3, width = 11.7)
message("Percentage Plot Saved to Working Directory")}
#Completion Plot
emaplot.count<-ggplot(data = emamelt.merge, aes(x=date, y=actual, color=Type, group=Type, shape=Type)) +
ggtitle(paste(Initial,"EMA Progress (Count)"))+
theme(plot.title = element_text(hjust = 0.5))+
geom_line()+
ylab("Percentage")+
scale_x_date(name="Date",limits = c(startdate+1,NA) ,date_breaks = "2 days")+
geom_point()+
ggrepel::geom_label_repel(data = emamelt.merge[(which(emamelt.merge$date %in% c(startdate+7,startdate+14,ifelse(enddate>Sys.Date(),Sys.Date(),enddate)))),], aes(x=date, y=actual,label=actual))+
ggrepel::geom_label_repel(data = emamelt.merge[(which(emamelt.merge$date %in% c(startdate+7,startdate+14,ifelse(enddate>Sys.Date(),Sys.Date(),enddate)) & emamelt.merge$Type %in% c("BoD","DoD","Total"))),], aes(x=date, y=expectation,label=expectation),color="black")
if (output){
ggsave(paste(Initial,"_EMAProg_CountPlot.jpeg",sep = ""),device = "jpeg",plot = emaplot.count,dpi = 300,path = path, height = 8.3, width = 11.7)
message("Completion (count) Plot Saved to Working Directory")}
if(codeout){return(list(percentgraph=emaplot.percent,countgraph=emaplot.count))}
} else {message("Skipping Graphing: Input data not compatible, possibly because no entry yet.")}
}
############### EMA 2 RedCap update function:
bsrc.ema.redcapupload<-function(emamelt.merge=NULL,startdate=NULL, enddate=NULL,protocol=protocol.cur,funema=NULL,output=T,ifupload=T,curver="2",idvar="redcapID",...){
#unpack protocol
input.token<-protocol$token
input.uri<-protocol$redcap_uri
rdpath<-protocol$rdpath
protocol.n<-protocol$name
#safe gurad the function:
if (is.null(funema)){funema<-bsrc.getform("ema_session_checklist",grabnewinfo = T, protocol=protocol,... = ...)}
#Pre-check
redcapID<-unique(emamelt.merge[[idvar]])
emamelt.merge$redcapID<-unique(emamelt.merge[[idvar]])
emamelt.merge[[idvar]]<-NULL
originaldata<-funema[which(funema$registration_redcapid==redcapID & funema$redcap_event_name=="ema_arm_1"),c("registration_redcapid","ema_completed___3","ema_completed___2","ema_completed___999","ema_termdate")]
originaldata$ema_completed___999->ninenineninestatus
originaldata$ema_termdate->termdatestatus
originaldata$ema_completed___2->twostatus
originaldata$ema_completed___3->threestatus
emamelt.merge<-emamelt.merge[which(!emamelt.merge$Type %in% c("MB","SetUp")),]
emamelt.merge$check<-NA
#emamelt.merge$check[which(emamelt.merge$date %in% c(startdate+7))]<-"3Days"
if(is.null(emamelt.merge$daysinstudy)){
emamelt.merge$check[which(emamelt.merge$date %in% c(startdate+7))]<-"7Days"
emamelt.merge$check[which(emamelt.merge$date %in% c(startdate+14))]<-"14Days"
emamelt.merge$check[which(emamelt.merge$date %in% c(startdate+21))]<-"21Days"
} else {
emamelt.merge$check[emamelt.merge$daysinstudy %in% c(7,14,21)]<-paste0(emamelt.merge$daysinstudy[emamelt.merge$daysinstudy %in% c(7,14,21)],"Days")
emamelt.merge$daysinstudy<-NULL
}
if (length(which(is.na(emamelt.merge$check))) != length(emamelt.merge$date)) {
test1<-reshape(emamelt.merge[!is.na(emamelt.merge$check),],idvar = "check",timevar = "Type",direction = "wide", v.names = c("actual","per"),drop = c("porp","expectation","diff"))
test1[which(test1$date>=Sys.Date()),grep("actual",names(test1))[1]:length(test1)]<-"NOT FINISH"
test1$date<-as.character(test1$date)
test2<-reshape(test1,idvar = "redcapID",timevar = "check",direction = "wide", v.names = names(test1)[-c(2,3)])
test3<-test2
names(test3)[!grepl("redcapID",names(test3))]<-paste("emapg_",names(test3)[!grepl("redcapID",names(test3))],sep = "")
names(test3)[grepl("redcapID",names(test3))]<-"registration_redcapid"
names(test3)<-tolower(gsub("[.]","_",names(test3)))
if (is.na(termdatestatus) | is.na(ninenineninestatus)){
if(Sys.Date()<enddate+1) {
test3$ema_completed___ip<-1
currentexp<-paste("test3$ema_completed___",curver,"<-0", sep = "")
eval(parse(text=currentexp))
test3$ema_completed___999<-0
test3$redcap_event_name<-"ema_arm_1"
}else {
test3$ema_completed___ip<-0
currentexp<-paste("test3$ema_completed___",curver,"<-1", sep = "")
eval(parse(text=currentexp))
test3$ema_completed___999<-0
test3$ema_termdate<-as.character(enddate)
test3$redcap_event_name<-"ema_arm_1"
test3$prog_emastatus_di<-NA
}
}else {
test3$ema_completed___ip<-0
test3$redcap_event_name<-"ema_arm_1"
test3$prog_emastatus_di<-NA
test3$ema_completed___999<-ninenineninestatus
test3$ema_completed___2<-twostatus
test3$ema_completed___3<-threestatus
}
}else {message(paste("Nothing to upload for",redcapID,"yet, come back after: ", startdate+7))
test3<-data.frame(registration_redcapid=unique(emamelt.merge$redcapID),ema_completed___ip="1")
#names(test3)<-c("registration_redcapid","ema_completed___ip")
test3$redcap_event_name<-"ema_arm_1"
test3$ema_completed___3<-0
test3$ema_completed___999<-0}
if (ifupload) {
result.test3<-REDCapR::redcap_write(test3,token = input.token,redcap_uri = input.uri)
if (result.test3$success) {print("DONE")}}
#if (updatelocaldb) {
#if (length(grep("date",names(test3)))>1){
#test3<-test3[,-grep("date",names(test3))]}
#funbsrc<-bsrc.updatedb(ndf = test3, df=funbsrc)}
if (output) {
return(test3)}
}
################ Get certrain part of EMA data
bsrc.ema.getevent<-function(emadata.raw,pick.input,additional=NA, vers="3") {
stop("This function will be depreciated, and the function call will be replaced by a different function in future updates")
if (missing(emadata.raw)) {
print("Using bsrc.ema.getfile() for data")
emadata.raw<-bsrc.ema.getfile()
}
if (missing(pick.input)) {
pick.input <- readline(prompt = "Please type in BoD, DoD, EoD or MB: ")
}
switch (vers,
"2" = ltrigger<-c("BoD","DoD","EoD","MB"),
"3" = ltrigger<-c("BoD_U","DoD_U","EoD_U","MB")
)
pick<-ltrigger[grep(pick.input,ltrigger)]
test<-emadata.raw
switch (pick,
"DoD" = {pick.w<-c("DoD","rp_")},
"EoD" = {pick.w<-c("EoD","eod_")},
"BoD" = {pick.w<-c("BoD","bod_")},
"DoD_U" = {pick.w<-c("DoD_U","rp_")},
"EoD_U" = {pick.w<-c("EoD_U","eod_")},
"BoD_U" = {pick.w<-c("BoD_U","bod_")},
"MB" = {pick.w<-c("MB","mb_")})
test1<-test[which(test$Survey_Class==pick.w[1]),grep(paste(pick.w[2],additional,'User_Id',sep = '|',collapse = "|"),names(test))]
return(test1)
}
################ Patch the data for emadata.raw and counts for 'em:
bsrc.ema.patch<-function(emadata.raw,vers="3",skipgetevent=F){
if (missing(emadata.raw)){
print("Using bsrc.ema.getfile() for data")
emadata.raw<-bsrc.ema.getfile()}
switch (vers,
"2" = ltrigger<-c("BoD","DoD","EoD","MB"),
"3" = ltrigger<-c("BoD_U","DoD_U","EoD_U","MB")
)
rownames(emadata.raw)<-NULL
emadata.raw<-bsrc.ema.scaletonum(emadata.raw = emadata.raw)
if (!skipgetevent){
dodonly<-bsrc.ema.getevent(emadata.raw = emadata.raw, pick.input = ltrigger[2], vers = vers)
}else{
emadata.raw->dodonly
}
negnumx<-grep(paste("angry","nervous","sad","irritated",sep = "|",collapse = "|"),names(dodonly))
negnum<-names(dodonly)[intersect(negnumx,grep(pattern = "rp_",names(dodonly)))]
negnum<-negnum[!grepl("_rn",negnum)]
dodonly$ifnegative<-rowSums(dodonly[,negnum] >= 2)>0
dodonly$ifintime<-dodonly$rp_time %in% c("Just happened","15 minutes","30 minutes","45 minutes")
emadata.raw$MB_YES<-FALSE
emadata.raw$MB_Timepoint<-NA
emadata.raw$MB_YES[which(dodonly$ifintime & dodonly$ifnegative)]<-TRUE
emadata.raw$MB_Timepoint[which(emadata.raw$MB_YES & emadata.raw$rp_time == "Just happened")]<-4
emadata.raw$MB_Timepoint[which(emadata.raw$MB_YES & emadata.raw$rp_time == "15 minutes")]<-3
emadata.raw$MB_Timepoint[which(emadata.raw$MB_YES & emadata.raw$rp_time == "30 minutes")]<-2
emadata.raw$MB_Timepoint[which(emadata.raw$MB_YES & emadata.raw$rp_time == "45 minutes")]<-1
return(emadata.raw)
}
############### Scale to Num
bsrc.ema.scaletonum<-function(emadata.raw){
if (missing(emadata.raw)){
print("Using bsrc.ema.getfile() for data")
emadata.raw<-bsrc.ema.getfile()}
emadata.nodate<-emadata.raw[,-grep("Date",names(emadata.raw))]
emadata.onlydate<-as.data.frame(emadata.raw[,grep("Date",names(emadata.raw))])
names(emadata.onlydate)<-names(emadata.raw)[grep("Date",names(emadata.raw))]
emadata.nodate[emadata.nodate == "Very Slightly or Not at All"]<-1
emadata.nodate[emadata.nodate == "A Little"]<-2
emadata.nodate[emadata.nodate == "Moderately"]<-3
emadata.nodate[emadata.nodate == "Quite a Bit"]<-4
emadata.nodate[emadata.nodate == "A great deal"]<-5
emadata.nodate[emadata.nodate == ""]<-NA
emadata.nodate[emadata.nodate == "CONDITION_SKIPPED"]<-NA
emadata.nums<-cbind(emadata.nodate,emadata.onlydate)
return(emadata.nums)
}
################################
#PENDING DX TOOL FOR PT
#############################
dnpl.ema.updatevariref<-function(filename=NULL){
if (is.null(filename)){
print("Please choose a file...")
filename<-file.choose()
}
vari<-read.csv(filename)
vari.valuevariname<-as.character(vari$variableName[which(vari$type != "INFORMATION")])
metadata<-list(metadata=vari,valuevariname=vari.valuevariname,updated.date=Sys.Date())
}
#############################
dnpl.ema.procdb<-function(rdpath=ema.data.rdpath,fulldata.ema=NULL,metadata.ema=NULL,...) {
if (is.null(fulldata.ema) & is.null(metadata.ema)) {
if (file.exists(rdpath)) {
envir.load<-invisible(bsrc.attachngrab(rdpath = rdpath,returnas = "envir"))
fulldata.ema<-envir.load$fulldata.ema
metadata.ema<-envir.load$metadata.ema
}
}
#Plug in more pre-processing steps
#info status:
fulldata.ema<-dnpl.ema.infochange(fulldata.ema = fulldata.ema)
#proc data spilt
fulldata.ema<-dnpl.ema.spiltraw(fulldata.ema = fulldata.ema,metadata.ema = metadata.ema,...)
#More stuff (device OS/daysinto the study):
fulldata.ema<-dnpl.ema.addmorestuff(fulldata.ema = fulldata.ema)
#End
assign("fulldata.ema",fulldata.ema,envir=envir.load)
save(list = objects(envir = envir.load),file = rdpath,envir = envir.load)
}
#############################
dnpl.ema.addmorestuff<-function(fulldata.ema) {
fulldata.ema$pdata$DeviceOS<-fulldata.ema$info$DeviceOS[match(fulldata.ema$pdata$redcapID,fulldata.ema$info$RedcapID)]
bodonly<-subset(fulldata.ema$pdata[which(fulldata.ema$pdata$Type=="BoD"),],select = c("date","redcapID","expectation"))
names(bodonly)[grep("expectation",names(bodonly))]<-"daysinstudy"
fulldata.ema$pdata<-merge(fulldata.ema$pdata,bodonly,all = TRUE)
return(fulldata.ema)
}
############################
dnpl.ema.infochange<-function(fulldata.ema=NULL,info_ss=NULL){
if(!is.null(fulldata.ema)){
fulldata.ema$info$status<-"UNKNOWN"
fulldata.ema$info$duration<-fulldata.ema$info$enddate-fulldata.ema$info$startdate
fulldata.ema$info$status[fulldata.ema$info$duration==21]<-"COMPLETED"
fulldata.ema$info$status[fulldata.ema$info$duration>21]<-"EXCESSIVE"
fulldata.ema$info$status[fulldata.ema$info$duration<21]<-"EARLY-TERMINATION"
endtarget<-merge(aggregate(date ~ redcapID + Type,data=fulldata.ema$pdata[which(fulldata.ema$pdata$Type=="Total"),], max),fulldata.ema$pdata,all.x=TRUE)
fulldata.ema$info$completion_rate<-endtarget$per[match(fulldata.ema$info$RedcapID,endtarget$redcapID)]
returnwhat<-fulldata.ema
} else if (!is.null(info_ss)){
message("Function is depreciated for this use.")
}
return(fulldata.ema)
}
############################
dnpl.ema.spiltraw<-function(fulldata.ema=fulldata.ema,metadata.ema=metadata.ema,getmore.u=NULL,base.n=NULL) {
if (is.null(base.n)){
base.n<-c("User_Id","Survey_Submitted_Date","Survey_Submitted_Time","TriggerName")
print(paste("by default, each form will include these variables: ",paste(base.n,collapse = " ;")))
}
genvariname<-c(base.n,getmore.u)
rawdata<-fulldata.ema$raw
proc.e<-fulldata.ema$pdata[which(fulldata.ema$pdata$Type=="BoD"),c("date","redcapID","expectation")]
names(proc.e)<-c("Survey_Submitted_Date","RedcapID","Days")
for (i in 1:length(names(metadata.ema))) {
formname<-names(metadata.ema)[i]
print(paste("Processing '",formname,"'.....",sep = ""))
formvariname<-metadata.ema[[formname]]$valuevariname
proc.a<-rawdata[,c(genvariname,formvariname)]
proc.b<-bsrc.ema.scaletonum(proc.a)
limitlength<-(unique(apply(proc.b, 1, function(x) {length(x)}))[1])-(length(genvariname))
proc.c<-proc.b[which(apply(proc.b, 1, function(x) {length(which(is.na(x)))})<limitlength),]
proc.c$RedcapID<-fulldata.ema$info$RedcapID[match(proc.c$User_Id,fulldata.ema$info$mwuserid)]
proc.c$CompletionRate<-as.numeric(apply(proc.c, 1, function(x) {1-(length(which(is.na(x))) / length(x))}))
proc.f<-merge(proc.c,proc.e,all.x = T, by.x = c("RedcapID","Survey_Submitted_Date"), by.y = c("RedcapID","Survey_Submitted_Date"))
str.e<-paste("fulldata.ema$procdata$",formname,"<-proc.f",sep = "")
eval(parse(text = str.e))
print("done")}
return(fulldata.ema)
}
###########################
########################
### ANALYSIS/GRAPH ###
########################
#############################
if(FALSE){
groupstat<-na.omit(subset(bsocial$data,select = c("registration_redcapid","fudemo_incomelevel")))
ema$fulldata.ema$pdata$income_b<-groupstat$fudemo_incomelevel[match(ema$fulldata.ema$pdata$redcapID,groupstat$registration_redcapid)]
ggplot(data = info_all,aes(x=StartDate,y=MBCount,color=Group)) + geom_point()
info_all$month<-factor(month.name[month(info_all$StartDate)],levels = month.name)
library(lme4)
summary(lm(scale(MBCount)~as.factor(Group)+month+scale(CompletionRate)+as.factor(DeviceOS),data = info_all))
summary(lm(scale(CompletionRate)~as.factor(Group)+month+scale(CompletionRate)+as.factor(DeviceOS),data = info_all))
}
dnpl.ema.missinggraph<-function(df, Typename="Type",path=getwd(),#referenceline=c("horizontal","diagonal")
referenceline="diagonal",
graphictype=c("jitter","gam"),
xa="expectation",ya="actual",by="redcapID",additional=NULL){
colnames(df)[grep(Typename,names(df))]<-"Type"
x.bse<-paste("ggplot(data = df.x, aes(x= ",xa,", y= ",ya,", color = ",by,"))",sep = "")
if (!is.null(referenceline)) {
if (any(referenceline %in% "horizontal")) {
referl.h<-"+ geom_abline(intercept = 50,slope = 0, size=0.8)"
} else {referl.h<-NULL}
if (any(referenceline %in% "diagonal")) {
referl.d<-"+ geom_abline(intercept = 0,slope = 1, size=0.8)"
} else {referl.d<-NULL}
referl<-paste(referl.h,referl.d,collapse = "",sep = " ")
}
if (!is.null(graphictype)) {
funclist<-list()
if (any(graphictype %in% "jitter")) {
funclist[["jitter"]]<-list(name="jitter",call="+ geom_jitter()")
}
if (any(graphictype %in% "gam")) {
funclist[["gam"]]<-list(name="gam",call="+ geom_smooth()")
}
}
for (i in unique(df$Type)) {
targettype=as.character(i)
print(targettype)
df.x<-df[which(df$Type==targettype),]
lapply(funclist,function(x) {
ggsave(filename = paste(paste(targettype,xa,ya,by,x$name,sep = "_"),".jpeg",sep=""),
device = "jpeg",
plot = eval(parse(text = paste(x.bse,
paste("+ ggtitle(paste(targettype,'",x$name,"'))",sep = ""),
referl,
ifelse(is.null(additional),'',paste("+",additional)),
x$call
))),
dpi = 300,path = path, height = 8.3, width = 11.7)
})
}
}
###############################
dnpl.ema.statsbyweek<-function(fulldata.ema=fulldata.ema){
yz<-apply(fulldata.ema$rdata[grep("emapg_per_",names(fulldata.ema$rdata))], 2, function(x) {
x<-na.omit(x)
if (length(agrep("*%",x))>0) {
x<-as.numeric(sapply(strsplit(x,split = " %"),"[[",1))
} else {x<-as.numeric(x)}
summary(na.omit(x))})
#fulldata.ema$pdata$
final<-list()
for (i in 1:length(rownames(yz))) {
y<-yz[i,]
typename<-rownames(yz)[i]
y<-as.data.frame(y)
ls.y<-strsplit(rownames(y),split = "_")
y$type<-sapply(ls.y, "[[",3)
y$time<-sapply(ls.y, "[[",4)
y<-reshape(y,direction = "wide",idvar = "type")
rownames(y)<-y$type
y$type<-NULL
names(y)<-sapply(strsplit(names(y),split = ".", fixed = T),"[[",2)
#y$mean<-apply(y, 1, mean)
#y.ex<-apply(y, 2, mean)
#y.x<-rbind(y,y.ex)
#rownames(y.x)<-c(rownames(y),"rownames")
final[[typename]]<-y
}
return(final)
}
################################
################Ver 2: Intergrated main and redcapupload (Single; Legacy)
bsrc.ema.oneshotupload<-function(filename.e,forceupdate.e=F,ifupload=T,curver.e="2", graphic.e=T){
if (missing(filename.e)) {
print("No file specified, please choose the target file")
filename.c<-file.choose()}
else {filename.e->filename.c}
bsrc.ema.redcapupload(emamelt.merge = bsrc.ema.main(emadata.raw = bsrc.ema.getfile(filename = filename.c), forceupdate.e = forceupdate.e, ifupload = T, graphic = graphic.e),ifupload = T,curver = curver.e)
}
bsrc.ema.procActualData<-function(dfb,metadata.ema){
dfb_sp<-split(dfb,dfb$Survey_Class)
dfb_spa<-lapply(names(dfb_sp),function(xname){
cleanupdf(dfb_sp[[xname]],metadata.ema[[match(tolower(xname),names(metadata.ema))]]$valuevariname)
})
names(dfb_spa)<-names(dfb_sp)
return(dfb_spa)
}
################ Loop:
bsrc.ema.loopit<-function(rdpath.ema=rdpaths$ema,loop.path=NULL, file=NULL,gpath,
graphic=T,updatedata=T,forcerun=F,ifupload.e=T,
local=F,curver.e="3",protocol=protocol.cur,
envir.load=NULL,...) {
message("!!!!!WARNING!!!!!!THIS FUNCTION IS FORMALLY REPLACED BY 'bsrc.ema.update' AND WILL NOT WORK WITH DATABASE!!!!")
Sys.sleep(30)
if(curver.e=="2" & is.null(loop.path)){loop.path<-getwd()}
if(curver.e=="3" & is.null(file)){filename<-file.choose()}
if(missing(gpath)) {
if(exists("ema.graph.path")){
gpath<-ema.graph.path
}else{gpath<-NULL}
}
if(is.null(gpath)){
message("Graphing is turned off because no graphic path provided...")
graphic=FALSE}
run2<-F
run3<-F
skip<-F
outcome.r.temp<-NULL
outcome.temp<-NULL
writetofile<-FALSE
fulldata.ema<-NULL
outcome<-NULL
outcome.r<-NULL
emadata.raw.combo<-NULL
info.combo<-NULL
#subreg<-bsrc.getevent(eventname = "enrollment_arm_1",subreg = T, protocol = protocol,... = ...)
funema<-bsrc.getform(formname = "ema_session_checklist",grabnewinfo = !local, protocol = protocol,... = ...)
subreg<-bsrc.getform(formname = c("record_registration","progress_check"),grabnewinfo = !local, protocol = protocol,... = ...)
protocol$redcap_uri->input.uri
protocol$token->input.token
if (file.exists(rdpath.ema)) {
envir.load<-invisible(bsrc.attachngrab(rdpath = rdpath.ema,returnas = "envir"))
fulldata.ema<-envir.load$fulldata.ema
metadata.ema<-envir.load$metadata.ema
pathsplit<-strsplit(rdpath.ema,split = "/")[[1]]
topath<-paste(paste(pathsplit[-length(pathsplit)],collapse = "/",sep = ""),"Backup","emaloop.backup.rdata",sep = "/")
file.copy(from = rdpath.ema, to = topath, overwrite = T)
message("Backed-up previousely used db, in case it broke...")
outcome<-fulldata.ema$pdata
outcome.r<-fulldata.ema$rdata
emadata.raw.combo<-fulldata.ema$raw
info.combo<-fulldata.ema$info
}else if (is.null(envir.load)) {envir.load<-new.env(parent = emptyenv())}
switch(curver.e,
"2" = {
loop.path->path
temp<-list.files(path,pattern="*.csv")
print("This is to upload and update redcap")
for (i in 1:length(temp)){
print(paste("Now reading file ",i," out of ",length(temp),sep = ""))
filename<-paste(path,temp[i],sep = "/")
emadata.raw<-bsrc.ema.getfile(filename = filename, curver = "2")
output.c<-bsrc.ema.main(emadata.raw = emadata.raw, graphic = graphic, path = gpath,subreg = subreg, funema = funema)
if (!as.character (output.c$info$RedcapID) %in% as.character(info.combo$RedcapID) | forcerun){
output<-output.c$data
startdate<-output.c$info$startdate
enddate<-output.c$info$enddate
output.r<-bsrc.ema.redcapupload(emamelt.merge = output,output = T, ifupload = F,curver = "2",startdate = startdate,enddate = enddate, funema = funema)
info<-output.c$info
if (i==1 & !skip)
{outcome<-output
outcome.r<-output.r
emadata.raw.combo<-emadata.raw
info.combo<-info
}
if (i==1) {
outcome.r.temp<-output.r
outcome.temp<-output}
outcome.r.temp<-merge(outcome.r.temp,output.r,all=T)
outcome.temp<-merge(outcome.temp,output,all=T)
if (output.r$ema_completed___2==1) {
writetofile<-TRUE
outcome<-merge(outcome,output,all=T)
outcome.r<-merge(outcome.r,output.r,all=T)
emadata.raw.combo<-merge(emadata.raw.combo,emadata.raw,all=T)
info.combo<-merge(info.combo,info,all=T)}
output<-NULL
output.r<-NULL
output<-NULL
output.r<-NULL
emadata.raw<-NULL
info<-NULL
}else{print("------SKIPPED; DATA ALREADY IN emadata.all.rdata--------")}
}#END of LOOP
},
"3" = {
message("!!!!!WARNING!!!!!!THIS FUNCTION IS FORMALLY REPLACED BY 'bsrc.ema.update' AND WILL NOT WORK WITH DATABASE!!!!")
emadata.raw<-NULL
emadata.raw<-bsrc.ema.getfile(filename = filename,curver = "3",funema = funema,envir=envir.load)
if (!forcerun & any(unique(emadata.raw$RedcapID) %in% as.character(info.combo$RedcapID))){
completedid<-unique(emadata.raw$RedcapID)[which(unique(emadata.raw$RedcapID) %in% as.character(info.combo$RedcapID))]
emadata.raw<-emadata.raw[which(is.na(match(emadata.raw$RedcapID,completedid))),]
message(paste("Skipped these IDs because they have completed: ",paste(completedid,collapse = ","),sep = ""))
}
outcome.r.temp<-data.frame()
outcome.temp<-data.frame()
for (i in 1:length(unique(emadata.raw$RedcapID))) {
message("!!!!!WARNING!!!!!!THIS FUNCTION IS FORMALLY REPLACED BY 'bsrc.ema.update' AND WILL NOT WORK WITH DATABASE!!!!")
message("##########################")
message(paste("Now processing ",i," out of ",length(unique(emadata.raw$RedcapID)),sep = ""))
message(unique(emadata.raw$RedcapID)[i])
curredcap<-unique(emadata.raw$RedcapID)[i]
currda<-emadata.raw[which(emadata.raw$RedcapID==curredcap),]
rownames(currda)<-NULL
fstatus<-F
output<-NULL
output.r<-NULL
tryCatch({
output.c<-bsrc.ema.main(emadata.raw = currda, graphic = graphic, path = gpath, subreg = subreg, funema = funema)
output<-output.c$data
startdate<-output.c$info$startdate
enddate<-output.c$info$enddate
},error=function(x){
message("EMA MAIN NOT DONE")
message(unique(emadata.raw$RedcapID)[i])
})
tryCatch({
output.r<-bsrc.ema.redcapupload(emamelt.merge = output,output = T, ifupload = F, curver = "3",startdate = startdate,enddate = enddate,funema = funema)
}, error=function(x){
message("REDCAP UPLOAD NOT DONE")
message(unique(emadata.raw$RedcapID)[i])
})
if (!is.null(output) & length(outcome.temp)==0){
outcome.temp<-output}
if (!is.null(output.r) & length(outcome.r.temp)==0) {
outcome.r.temp<-output.r
}
if (!is.null(output)) {
message("MERGING MAIN")
outcome.temp<-merge(outcome.temp,output,all = T)
}
if (!is.null(output.r)) {
message("MERGING REDCAP")
outcome.r.temp<-merge(outcome.r.temp,output.r,all = T)
}
if (!is.null(output.r)) {
if (output.r$ema_completed___3==1 | output.r$ema_completed___999==1) {
writetofile<-TRUE
message("**COMPLETED/TERMINATED**")
message("Adding this person to EMA database")
info<-output.c$info
outcome<-merge(outcome,output,all=T)
outcome.r<-merge(outcome.r,output.r,all=T)
emadata.raw.combo<-merge(emadata.raw.combo,currda,all=T)
info.combo<-merge(info.combo,info,all=T)
currda<-NULL
info<-NULL}}
} #End of Loop
})
outcome<-outcome[which(!outcome$porp %in% c("NaN",NA)),]
outcome.temp<-outcome.temp[which(!outcome.temp$porp %in% c("NaN",NA)),]
if (updatedata & writetofile){
message("Saving back to file...")
fulldata.ema<-list(info=info.combo,pdata=outcome,rdata=outcome.r,raw=emadata.raw.combo,update.date=Sys.Date())
assign("fulldata.ema",fulldata.ema,envir=envir.load)
save(list = objects(envir.load),file = rdpath.ema,envir = envir.load)
dnpl.ema.procdb(rdpath = rdpath.ema)
}
if (ifupload.e) {
if (length(outcome.r.temp$registration_redcapid)>0){
message("Starting to upload updates to RedCap...")
result.outcome.r<-REDCapR::redcap_write(outcome.r.temp,token = input.token,redcap_uri = input.uri)
if (result.outcome.r$success) {message("DONE")} else {message("SOMETHING WENT WRONG")}
}else{message("Nothing to upload...closing down...")}
} else {message("ifupload.e arugement is FALSE, no uploading")}
return(list(main=outcome.temp,redcapupload=outcome.r.temp))
}
#####################
########END##########
#####################
#Construction:
#New orgnization and looping:
#input:
# raw_fpath=file.choose()
# ema_raw=NULL
# protocol=protocol.cur
# emardpath=rdpaths$ema
# ss.graph=T
# graph_path=ema.graph.path
# local=F
# restricData=T
# forceRerun=F
# updateRC=T
# excludeID=c("")
if(FALSE){
#!stucture of new environment:
newenvir_ema<-new.env()
envir_ema$matchdb->newenvir_ema$matchdb #no need to worry about that
newenvir_ema$CompletedData$CompletionRateData<-lapply(completed_sub,function(sx){sx$data})
do.call(rbind,lapply(completed_sub,function(sx){sx$info}))
fulldata.ema<-list(info=info.combo,pdata=outcome,rdata=outcome.r,raw=emadata.raw.combo,update.date=Sys.Date())
metadata.ema<-ema$metadata.ema
ema_raw_old_proc<-envir_ema$fulldata.ema$raw
ema_raw_old_proc<-as.data.frame(apply(ema_raw_old_proc,2,as.character),stringsAsFactors = F)
completed<-bsrc.ema.rawtolist(ema_raw = ema_raw_old_proc, rc_ema = rc_ema, envir_ema = envir_ema)
completed_sub<-lapply(X = completed,FUN = bsrc.ema.singlesubproc,graphic=F,graph_path=graph_path)
info.df<-do.call(rbind,lapply(completed_sub,function(xz){xz$info}))
info.df<-info.df[order(info.df$EndDate),]
#rownames(info.df)<-NULL
completed$`203182`->dfb
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.