Commit 9b88270d authored by Gorman Sanisaca, Lillian E's avatar Gorman Sanisaca, Lillian E
Browse files

changes in response to peer review comments

parent 79afce20
This diff is collapsed.
......@@ -17,19 +17,41 @@
#The Compare.R Rscript compares previously calculated loads generated by PSLoadEsT
#with current load calculations.
#ONLY unaltered output tables from PSloadEsT can be used for the load comparison.
#Required previously generaged tables :
#load_summary_by_discharger.csv
#load_summary_byMonth_lt34.csv
#load_summary_bySeason.csv
#load_summary_by12Month.csv
#Required Input Objects from postCalc.RData file and loadFunctions.R file
#scriptPATH : path to loadFunctions.R file
#fileName : name of current script
#Path : path to current script
#Path32 : path to 32-bit version of Rscript.exe
#OUTputs : output tables selected within interface
#ThisFile : path to PSLoadEsT.accdb file
#comDir : user designated directory for .csv files (Required previously generaged tables)
#load_summary_by_discharger : current run output table from LoadCalc.R
#load_summary_byMonth_lt34 : current run output table from LoadCalc.R
#load_summary_bySeason : current run output table from LoadCalc.R
#load_summary_by12Month : current run output table from LoadCalc.R
#removeDFs : function to remove objects from worksapce to free memory space (function from loadFunctions.R)
#outRemove : function to output to .csv or Results.accdb file and remove object from workspace (function from loadFunctions.R)
#OUTpath : path to Results.accdb file
#OUTchannel : open ODBC channel to Results.accdb file
#Spath : path to sizeTest.accdb file
#Schannel : open ODBC channel to sizeTest.accdb file
#Differences and Percent differences for all numeric fields will be reported
#all objects are saved to ~/Rscripts/postCalc.RData
#Possible output tables (selected by user) saved to users output directory :
#compare_load_summary_by_discharger.csv
#compare_load_summary_by12Month.csv
#compare_load_summary_byMonth_lt34.csv
#compare_load_summary_bySeason.csv
#info in documentation section ---
#info in documentation section 5.11.3
cat('\n \nPlease Wait for Compare.R Rscript to complete \nDO NOT close this window!\n \n')
......@@ -54,7 +76,6 @@ system(paste(Path32," ",file.path(gsub("loadFunctions.R","in32bit.R",scriptPATH)
load(gsub("loadFunctions.R","temp.RData",scriptPATH))
#compare directory
#comDir<-as.character(sqlQuery(channel, "SELECT* FROM Paths")$ComparePath)
comDir<-as.character(comDir$ComparePath)
comList<-list.files(comDir,pattern=".csv")
......@@ -71,7 +92,6 @@ for (tbl in OUTputs$Input_Table){
system(paste(Path32," ",file.path(gsub("loadFunctions.R","in32bit.R",scriptPATH)),sep=""), wait = TRUE, invisible = TRUE)
load(gsub("loadFunctions.R","temp.RData",scriptPATH))
#tblname<-sqlQuery(channel,"SELECT* from OutputTables")
tblname<-as.character(tblname[which(tblname$Good_TableName==tbl),]$Table)
table<-get(tblname)
if (length(comtbl)!=0 & exists(tblname)){#if both compare and orignial tables exist
......@@ -79,11 +99,11 @@ for (tbl in OUTputs$Input_Table){
#fix outfall
if (length(names(comtbl)[which(names(comtbl)=="outfall")])!=0){
comtbl$outfall<- as.character(comtbl$outfall)
comtbl$outfall<-sapply(comtbl$outfall, function(x) ifelse(!is.na(x) & nchar(x)<3,zeroPad(x,3),x))
comtbl$outfall<- as.character(comtbl$outfall)
comtbl$outfall<-sapply(comtbl$outfall, function(x) ifelse(!is.na(x) & nchar(x)<3,zeroPad(x,3),x))
}
#subset if load_summar_by_discharger
#subset if load_summar_by_discharger
goodFlds<-Fields[which(Fields$InputTable=="FACILITIES"),]
goodFieldNames<-as.character(goodFlds$Input_Field)
badFlds<-names(FACILITIES)[which(!names(FACILITIES) %in% goodFieldNames)]
......@@ -98,36 +118,36 @@ for (tbl in OUTputs$Input_Table){
#fix treatment_level
if (length(names(comtbl)[which(names(comtbl)=="treatment_level")])!=0){
comtbl$treatment_level<-ifelse(is.na(comtbl$treatment_level),"NA",comtbl$treatment_level)
table$treatment_level<-ifelse(is.na(table$treatment_level),"NA",table$treatment_level)
}
comtbl$treatment_level<-ifelse(is.na(comtbl$treatment_level),"NA",comtbl$treatment_level)
table$treatment_level<-ifelse(is.na(table$treatment_level),"NA",table$treatment_level)
}
comtbl<-merge(comtbl,table[,which(names(table)!="year")], by = group)
for (c in nongroup){
if (class(eval(parse(text=paste("comtbl$",c,".y",sep=""))))=="numeric" & regexpr("calc",paste(c,".y",sep=""))<0){
comtbl$difference_<-eval(parse(text=paste("round(comtbl$",c,".y","-comtbl$",c,".x,5)",sep="")))
comtbl$percentDiff_<-eval(parse(text=paste("comtbl$difference_/comtbl$",c,".x","*100",sep="")))
names(comtbl)[(length(comtbl)-1):length(comtbl)]<-paste(names(comtbl)[(length(comtbl)-1):length(comtbl)],c,sep="")
}
comtbl$difference_<-eval(parse(text=paste("round(comtbl$",c,".y","-comtbl$",c,".x,5)",sep="")))
comtbl$percentDiff_<-eval(parse(text=paste("comtbl$difference_/comtbl$",c,".x","*100",sep="")))
names(comtbl)[(length(comtbl)-1):length(comtbl)]<-paste(names(comtbl)[(length(comtbl)-1):length(comtbl)],c,sep="")
}
comtbl<-comtbl[,which(!names(comtbl)==paste(c,".x",sep=""))]
names(comtbl)[which(names(comtbl)==paste(c,".y",sep=""))]<-c
}
comtbl<-merge(comtbl,table[,which(names(table) %in% c(group,"year"))], by=group)
#fix treatment_level
if (length(names(comtbl)[which(names(comtbl)=="treatment_level")])!=0){
comtbl$treatment_level<-ifelse(comtbl$treatment_level=="NA",NA,comtbl$treatment_level)
}
assign(paste("compare_",tblname,sep=""),comtbl)
}
}
}
......
This diff is collapsed.
......@@ -20,13 +20,55 @@
#for the DMR and FLOW tables remarkFunc() and valueFunc() are triggered for concentration and flow fields
#see loadFunctions.R for details on custom functions
#all objects are saved to ~/Rscripts/LoadPrep_part1.RData
#no tables are directly output from this script, all tables generated are passed to the Sites.R script
#info in documentation section ---
#Required Input Objects from Sites.RData file and loadFunctions.R file
#scriptPATH : path to loadFunctions.R file
#Path32 : path to 32-bit version of Rscript.exe
#OUTputs : output tables selected within interface
#ThisFile : path to PSLoadEsT.accdb file
#DMR : output table from Import.R
#FLOW : output table from Import.R
#remarkFunc : generate remark codes for non-numeric data (function from loadFunctions.R)
#valueFunc : remove text from numeric fields (function from loadFunctions.R)
#rawCorefldNames : c("c1","c2","c3","q1","q2")
#removeDFs : function to remove objects from worksapce to free memory space (function from loadFunctions.R)
#outRemove : function to output to .csv or Results.accdb file and remove object from workspace (function from loadFunctions.R)
#convertClass : converts fields to correct class designation (function from loadFunctions.R)
#OUTpath : path to Results.accdb file
#OUTchannel : open ODBC channel to Results.accdb file
#Spath : path to sizeTest.accdb file
#Schannel : open ODBC channel to sizeTest.accdb file
#1 or more of the following tables imported from PSLoadEsT interface
#DMR_DuplicatesKept
#FLOW_DuplicatesKept
#LIMITS_DuplicatesKept
#FACILITIES_DuplicatesKept
#National_Medians_DuplicatesKept
#sic_codes_DuplicatesKept
#State_Expansion_DuplicatesKept
#Possible output tables saved to users output directory :
#DMR_DuplicatesKept.csv
#DMR_DuplicatesRemoved.csv
#FACILITIES_DuplicatesKept.csv
#FACILITIES_DuplicatesRemoved.csv
#FLOW_DuplicatesKept.csv
#FLOW_DuplicatesRemoved.csv
#LIMITS_DuplicatesKept.csv
#LIMITS_DuplicatesRemoved.csv
#National_Medians_DuplicatesKept.csv
#National_Medians_DuplicatesRemoved.csv
#Rubin_TPC_DuplicatesKept.csv
#Rubin_TPC_DuplicatesRemoved.csv
#sic_codes_DuplicatesKept.csv
#sic_codes_DuplicatesRemoved.csv
#info in documentation section 5.7.1
cat('\n \nPlease Wait for DupFix.R Rscript to complete \nDO NOT close this window!\n \n')
#load .RData
#load(file.path(gsub("loadFunctions.R","Sites.RData",scriptPATH)))
#load .Rprofile
source(scriptPATH)
fileName<-"Sites.R"
......@@ -36,186 +78,182 @@ for (tbl in as.character(unique(OUTputs[which(OUTputs$Input_Table %in% vars$Tabl
removeDFs(NA,c("table","DUPS","DUPSorig","Kdups","Rdups","remark","temp","temp2"))
if (exists(paste(tbl,"_DuplicatesKept",sep=""))){
#test if any duplciates kept
testDUP<-get(paste(tbl,"_DuplicatesKept",sep=""))
if (nrow(testDUP)!=0){
table<-get(tbl)
#get user selected duplicates
DUPSorig<-testDUP
#get PSLoadEst tables
strQuery<-paste("Select* from ",tbl,"_DuplicatesKept",sep="")
tblName<-c("DUPS")
dbPath<-ThisFile
save(file=file.path(gsub("loadFunctions.R","temp.RData",scriptPATH)),list=c("strQuery","tblName","dbPath"))
system(paste(Path32," ",file.path(gsub("loadFunctions.R","in32bit.R",scriptPATH)),sep=""), wait = TRUE, invisible = TRUE)
load(gsub("loadFunctions.R","temp.RData",scriptPATH))
#DUPS<-sqlQuery(channel,paste("Select* from ",tbl,"_DuplicatesKept",sep=""))
if (nrow(DUPS)!=0){
DUPS$duplicateRemoved<-ifelse(DUPS$duplicateRemoved==-1 | DUPS$duplicateRemoved=="TRUE",TRUE,FALSE)
}else if (nrow(DUPS)==0){
mat<-as.data.frame(matrix(TRUE,ncol=1,nrow=0))
names(mat)<-c("duplicateRemoved")
DUPS<-cbind(DUPS,mat)
}
#Fix fields
if (length(names(DUPS)[which(names(DUPS)=="date")])!=0){#date appears in table
DUPS$date<-as.Date(as.character(DUPS$date),format="%Y-%m-%d")
}
if (length(names(DUPS)[which(names(DUPS)=="start_date")])!=0){#start_date appears in table
DUPS$start_date<-as.Date(as.character(DUPS$start_date),format="%Y-%m-%d")
}
if (length(names(DUPS)[which(names(DUPS)=="parameter")])!=0){#parameter appears in table
DUPS$parameter<-zeroPad(as.character(as.numeric(DUPS$parameter)),5)
}
if (length(names(DUPS)[which(names(DUPS)=="outfall")])!=0){#outfall appears in table
#DUPS$outfall<-as.character(as.numeric(DUPS$outfall))
DUPS$outfall<- as.character(DUPS$outfall)
DUPS$outfall<-sapply(DUPS$outfall, function(x) ifelse(!is.na(x) & nchar(x)<3,zeroPad(x,3),x))
}
if (length(names(DUPS)[which(names(DUPS)=="treatment_level")])!=0){#treatment_level appears in table
DUPS$treatment_level<-ifelse(is.na(DUPS$treatment_level),"NA",as.character(DUPS$treatment_level))
table$treatment_level<-ifelse(is.na(table$treatment_level),"NA",as.character(table$treatment_level))
}
#save duplicates kept (includes selection to remove)
Kdups<-DUPS
if (length(names(Kdups)[which(names(Kdups)=="treatment_level")])!=0){#treatment_level appears in table
Kdups$treatment_level<-ifelse(Kdups$treatment_level=="NA",NA,Kdups$treatment_level)
}
assign(paste(tbl,"_DuplicatesKept",sep=""),Kdups)
outRemove(paste(tbl,"_DuplicatesKept",sep=""))
if (length(names(Kdups)[which(names(Kdups)=="treatment_level")])!=0){#treatment_level appears in table
Kdups$treatment_level<-ifelse(is.na(Kdups$treatment_level),"NA",Kdups$treatment_level)
}
#save removed duplicates
DUPS<-DUPS[which(DUPS$duplicateRemoved==TRUE),]
DUPS<-DUPS[,which(names(DUPS)!="Row")]
# DUPS<-DUPSorig[which(DUPSorig$Row %in% DUPS$Row),which(names(DUPSorig)!="Row")]
Rdups<-rbind(get(paste(tbl,"_DuplicatesRemoved",sep="")),DUPS)
assign(paste(tbl,"_DuplicatesRemoved",sep=""),Rdups)
outRemove(paste(tbl,"_DuplicatesRemoved",sep=""))
#before join convert all fields to character
classTable<-cbind(names(table), sapply(table, class))
classDUPS<-cbind(names(DUPS), sapply(DUPS, class))
table<-as.data.frame(sapply(table, function(x) as.character(x)))
table<-as.data.frame(sapply(table, function(x) ifelse(is.na(x),"NA",as.character(x))))
table<-as.data.frame(sapply(table, function(x) ifelse(x=="","NA",as.character(x))))
DUPS<-as.data.frame(sapply(DUPS, function(x) as.character(x),simplify=FALSE))
if (nrow(DUPS)!=0){
DUPS<-as.data.frame(sapply(DUPS, function(x) ifelse(is.na(x),"NA",as.character(x)),simplify=FALSE))
DUPS<-as.data.frame(sapply(DUPS, function(x) ifelse(x=="","NA",as.character(x)),simplify=FALSE))
}
names(DUPS)<-as.character(classDUPS[,1])
#remove user selected dups from table and flag remark as removed
table<-anti_join(table,DUPS, by=names(table)[which(regexpr("duplicate",names(table))<0)])
#convert back to original type
table<-as.data.frame(sapply(table, function(x) ifelse(x=="NA",NA,as.character(x))))
DUPS<-as.data.frame(sapply(DUPS, function(x) ifelse(x=="NA",NA,as.character(x)),simplify=FALSE))
names(DUPS)<-as.character(classDUPS[,1])
for (c in 1:nrow(classTable)){
table[[c]]<-convertClass(as.character(classTable[[c,2]]),"table",as.character(classTable[[c,1]]))
}
for (c in 1:nrow(classDUPS)){
DUPS[[c]]<-convertClass(as.character(classDUPS[[c,2]]),"DUPS",as.character(classDUPS[[c,1]]))
}
remark<-table
remark$duplicateFound<-FALSE
remark$duplicateType<-as.numeric(NA)
remark$duplicateRemoved<-FALSE
remark<-rbind(remark,Rdups)
Kdups<-Kdups[which(Kdups$duplicateRemoved==FALSE),]
#before join convert class
classKdups<-cbind(names(Kdups), sapply(Kdups, class))
classremark<-cbind(names(remark), sapply(remark, class))
Kdups<-as.data.frame(sapply( Kdups, function(x) as.character(x),simplify=FALSE))
if (nrow(Kdups)!=0){
Kdups<-as.data.frame(sapply( Kdups, function(x) ifelse(is.na(x),"NA",as.character(x)),simplify=FALSE))
Kdups<-as.data.frame(sapply(Kdups, function(x) ifelse(x=="","NA",as.character(x)),simplify=FALSE))
}
remark<-as.data.frame(sapply(remark, function(x) as.character(x)))
remark<-as.data.frame(sapply(remark, function(x) ifelse(is.na(x),"NA",as.character(x))))
remark<-as.data.frame(sapply(remark, function(x) ifelse(x=="","NA",as.character(x))))
names(remark)<-as.character(classremark[,1])
names(Kdups)<-as.character(classKdups[,1])
Kdups<-semi_join(Kdups,remark, by=names(Kdups)[which(regexpr("duplicate",names(Kdups))<0 & names(Kdups)!="Row")])
remark<-anti_join(remark, Kdups, by=names(remark)[which(regexpr("duplicate",names(remark))<0 & names(remark)!="Row")])
remark<-rbind(remark,Kdups[,which(names(Kdups)!="Row")])
#convert back to original type
Kdups<-as.data.frame(sapply(Kdups, function(x) ifelse(x=="NA",NA,as.character(x)),simplify=FALSE))
remark<-as.data.frame(sapply(remark, function(x) ifelse(x=="NA",NA,as.character(x))))
names(remark)<-as.character(classremark[,1])
names(Kdups)<-as.character(classKdups[,1])
for (c in 1:nrow(classKdups)){
Kdups[[c]]<-convertClass(as.character(classKdups[[c,2]]),"Kdups",as.character(classKdups[[c,1]]))
}
for (c in 1:nrow(classremark)){
remark[[c]]<-convertClass(as.character(classremark[[c,2]]),"remark",as.character(classremark[[c,1]]))
}
#removeduplciate found if not type 1-5
#edit 6.18.19
remark<-transform(remark, duplicateFound = ifelse(is.na(duplicateType),FALSE,TRUE))
remark<-transform(remark, duplicateRemoved = ifelse(duplicateType %in% c(1,2,3),TRUE,duplicateRemoved))
#test if any duplciates kept
testDUP<-get(paste(tbl,"_DuplicatesKept",sep=""))
if (tbl %in% c("DMR", "FLOW")){
#add remark codes and numeric value fields
for (func in c("remarkFunc","valueFunc")){
strfunc<-paste(func, "(x)",sep="")
for (fld in rawCorefldNames){
temp<-remark[c(fld)]
temp<-as.data.frame(matrix(apply(temp, 1, function(x) eval(parse(text=strfunc))),ncol=1))
temp2<-table[c(fld)]
temp2<-as.data.frame(matrix(apply(temp2, 1, function(x) eval(parse(text=strfunc))),ncol=1))
if (func=="remarkFunc"){
names(temp)<-paste("remark_",fld,sep="")
names(temp2)<-paste("remark_",fld,sep="")
}else if (func=="valueFunc"){
if (regexpr("c",fld)>0){
names(temp)<-paste("con",fld,sep="")
names(temp2)<-paste("con",fld,sep="")
}else if (!regexpr("c",fld)>0){
names(temp)<-paste("quan",substr(fld,2,2),sep="")
names(temp2)<-paste("quan",substr(fld,2,2),sep="")
}
}
remark<-cbind(remark,temp)
table<-cbind(table,temp2)
}#for each data column
}#for each func
}
assign(paste(tolower(tbl),"_remark",sep=""),remark)
if (nrow(testDUP)!=0){
table<-get(tbl)
#get user selected duplicates
DUPSorig<-testDUP
#get PSLoadEst tables
strQuery<-paste("Select* from ",tbl,"_DuplicatesKept",sep="")
tblName<-c("DUPS")
dbPath<-ThisFile
save(file=file.path(gsub("loadFunctions.R","temp.RData",scriptPATH)),list=c("strQuery","tblName","dbPath"))
system(paste(Path32," ",file.path(gsub("loadFunctions.R","in32bit.R",scriptPATH)),sep=""), wait = TRUE, invisible = TRUE)
load(gsub("loadFunctions.R","temp.RData",scriptPATH))
if (nrow(remark)!=0){
remark$Row<-rownames(remark)
}else if (nrow(remark)==0){
mat<-as.data.frame(matrix(1,ncol=1,nrow=0))
names(mat)<-c("Row")
remark<-cbind(remark,mat)
if (nrow(DUPS)!=0){
DUPS$duplicateRemoved<-ifelse(DUPS$duplicateRemoved==-1 | DUPS$duplicateRemoved=="TRUE",TRUE,FALSE)
}else if (nrow(DUPS)==0){
mat<-as.data.frame(matrix(TRUE,ncol=1,nrow=0))
names(mat)<-c("duplicateRemoved")
DUPS<-cbind(DUPS,mat)
}
#Fix fields
if (length(names(DUPS)[which(names(DUPS)=="date")])!=0){#date appears in table
DUPS$date<-as.Date(as.character(DUPS$date),format="%Y-%m-%d")
}
if (length(names(DUPS)[which(names(DUPS)=="start_date")])!=0){#start_date appears in table
DUPS$start_date<-as.Date(as.character(DUPS$start_date),format="%Y-%m-%d")
}
if (length(names(DUPS)[which(names(DUPS)=="parameter")])!=0){#parameter appears in table
DUPS$parameter<-zeroPad(as.character(as.numeric(DUPS$parameter)),5)
}
if (length(names(DUPS)[which(names(DUPS)=="outfall")])!=0){#outfall appears in table
DUPS$outfall<- as.character(DUPS$outfall)
DUPS$outfall<-sapply(DUPS$outfall, function(x) ifelse(!is.na(x) & nchar(x)<3,zeroPad(x,3),x))
}
if (length(names(DUPS)[which(names(DUPS)=="treatment_level")])!=0){#treatment_level appears in table
DUPS$treatment_level<-ifelse(is.na(DUPS$treatment_level),"NA",as.character(DUPS$treatment_level))
table$treatment_level<-ifelse(is.na(table$treatment_level),"NA",as.character(table$treatment_level))
}
#save duplicates kept (includes selection to remove)
Kdups<-DUPS
if (length(names(Kdups)[which(names(Kdups)=="treatment_level")])!=0){#treatment_level appears in table
Kdups$treatment_level<-ifelse(Kdups$treatment_level=="NA",NA,Kdups$treatment_level)
}
assign(paste(tbl,"_DuplicatesKept",sep=""),Kdups)
outRemove(paste(tbl,"_DuplicatesKept",sep=""))
if (length(names(Kdups)[which(names(Kdups)=="treatment_level")])!=0){#treatment_level appears in table
Kdups$treatment_level<-ifelse(is.na(Kdups$treatment_level),"NA",Kdups$treatment_level)
}
#save removed duplicates
DUPS<-DUPS[which(DUPS$duplicateRemoved==TRUE),]
DUPS<-DUPS[,which(names(DUPS)!="Row")]
Rdups<-rbind(get(paste(tbl,"_DuplicatesRemoved",sep="")),DUPS)
assign(paste(tbl,"_DuplicatesRemoved",sep=""),Rdups)
outRemove(paste(tbl,"_DuplicatesRemoved",sep=""))
#before join convert all fields to character
classTable<-cbind(names(table), sapply(table, class))
classDUPS<-cbind(names(DUPS), sapply(DUPS, class))
table<-as.data.frame(sapply(table, function(x) as.character(x)))
table<-as.data.frame(sapply(table, function(x) ifelse(is.na(x),"NA",as.character(x))))
table<-as.data.frame(sapply(table, function(x) ifelse(x=="","NA",as.character(x))))
DUPS<-as.data.frame(sapply(DUPS, function(x) as.character(x),simplify=FALSE))
if (nrow(DUPS)!=0){
DUPS<-as.data.frame(sapply(DUPS, function(x) ifelse(is.na(x),"NA",as.character(x)),simplify=FALSE))
DUPS<-as.data.frame(sapply(DUPS, function(x) ifelse(x=="","NA",as.character(x)),simplify=FALSE))
}
names(DUPS)<-as.character(classDUPS[,1])
#remove user selected dups from table and flag remark as removed
table<-anti_join(table,DUPS, by=names(table)[which(regexpr("duplicate",names(table))<0)])
#convert back to original type
table<-as.data.frame(sapply(table, function(x) ifelse(x=="NA",NA,as.character(x))))
DUPS<-as.data.frame(sapply(DUPS, function(x) ifelse(x=="NA",NA,as.character(x)),simplify=FALSE))
names(DUPS)<-as.character(classDUPS[,1])
for (c in 1:nrow(classTable)){
table[[c]]<-convertClass(as.character(classTable[[c,2]]),"table",as.character(classTable[[c,1]]))
}
for (c in 1:nrow(classDUPS)){
DUPS[[c]]<-convertClass(as.character(classDUPS[[c,2]]),"DUPS",as.character(classDUPS[[c,1]]))
}
remark<-table
remark$duplicateFound<-FALSE
remark$duplicateType<-as.numeric(NA)
remark$duplicateRemoved<-FALSE
remark<-rbind(remark,Rdups)
Kdups<-Kdups[which(Kdups$duplicateRemoved==FALSE),]
#before join convert class
classKdups<-cbind(names(Kdups), sapply(Kdups, class))
classremark<-cbind(names(remark), sapply(remark, class))
Kdups<-as.data.frame(sapply( Kdups, function(x) as.character(x),simplify=FALSE))
if (nrow(Kdups)!=0){
Kdups<-as.data.frame(sapply( Kdups, function(x) ifelse(is.na(x),"NA",as.character(x)),simplify=FALSE))
Kdups<-as.data.frame(sapply(Kdups, function(x) ifelse(x=="","NA",as.character(x)),simplify=FALSE))
}
remark<-as.data.frame(sapply(remark, function(x) as.character(x)))
remark<-as.data.frame(sapply(remark, function(x) ifelse(is.na(x),"NA",as.character(x))))
remark<-as.data.frame(sapply(remark, function(x) ifelse(x=="","NA",as.character(x))))
names(remark)<-as.character(classremark[,1])
names(Kdups)<-as.character(classKdups[,1])
Kdups<-semi_join(Kdups,remark, by=names(Kdups)[which(regexpr("duplicate",names(Kdups))<0 & names(Kdups)!="Row")])
remark<-anti_join(remark, Kdups, by=names(remark)[which(regexpr("duplicate",names(remark))<0 & names(remark)!="Row")])
remark<-rbind(remark,Kdups[,which(names(Kdups)!="Row")])
#convert back to original type
Kdups<-as.data.frame(sapply(Kdups, function(x) ifelse(x=="NA",NA,as.character(x)),simplify=FALSE))
remark<-as.data.frame(sapply(remark, function(x) ifelse(x=="NA",NA,as.character(x))))
names(remark)<-as.character(classremark[,1])
names(Kdups)<-as.character(classKdups[,1])
for (c in 1:nrow(classKdups)){
Kdups[[c]]<-convertClass(as.character(classKdups[[c,2]]),"Kdups",as.character(classKdups[[c,1]]))
}
for (c in 1:nrow(classremark)){
remark[[c]]<-convertClass(as.character(classremark[[c,2]]),"remark",as.character(classremark[[c,1]]))
}
#removeduplciate found if not type 1-5
#edit 6.18.19
remark<-transform(remark, duplicateFound = ifelse(is.na(duplicateType),FALSE,TRUE))
remark<-transform(remark, duplicateRemoved = ifelse(duplicateType %in% c(1,2,3),TRUE,duplicateRemoved))
if (tbl %in% c("DMR", "FLOW")){
#add remark codes and numeric value fields
for (func in c("remarkFunc","valueFunc")){
strfunc<-paste(func, "(x)",sep="")
for (fld in rawCorefldNames){
temp<-remark[c(fld)]
temp<-as.data.frame(matrix(apply(temp, 1, function(x) eval(parse(text=strfunc))),ncol=1))
temp2<-table[c(fld)]
temp2<-as.data.frame(matrix(apply(temp2, 1, function(x) eval(parse(text=strfunc))),ncol=1))
if (func=="remarkFunc"){
names(temp)<-paste("remark_",fld,sep="")
names(temp2)<-paste("remark_",fld,sep="")
}else if (func=="valueFunc"){
if (regexpr("c",fld)>0){
names(temp)<-paste("con",fld,sep="")
names(temp2)<-paste("con",fld,sep="")
}else if (!regexpr("c",fld)>0){
names(temp)<-paste("quan",substr(fld,2,2),sep="")
names(temp2)<-paste("quan",substr(fld,2,2),sep="")
}
}
remark<-cbind(remark,temp)
table<-cbind(table,temp2)
}#for each data column
}#for each func
}
assign(paste(tolower(tbl),"_remark",sep=""),remark)
if (nrow(remark)!=0){
remark$Row<-rownames(remark)
}else if (nrow(remark)==0){
mat<-as.data.frame(matrix(1,ncol=1,nrow=0))
names(mat)<-c("Row")
remark<-cbind(remark,mat)
}
assign(tbl,table)
}
assign(tbl,table)
}
}
}
\ No newline at end of file
......@@ -22,7 +22,16 @@
#data can change, but required table and field names MUST NOT CHANGE
#all objects are saved to ~/Rscripts/postCalc.RData
#output tables are saved to the (userDirectory)/ControlFile.accdb
#info in documentation section ---
#Required Input Objects from postCalc.RData file and loadFunctions.R file
#scriptPATH : path to loadFunctions.R file
#Path32 : path to 32-bit version of Rscript.exe
#fileName : name of current script