From 6cd4db533fa762a41f673775ee06623759970388 Mon Sep 17 00:00:00 2001 From: nmprista <31890653+nmprista@users.noreply.github.com> Date: Thu, 19 Oct 2023 13:53:39 +0200 Subject: [PATCH] fixed code and tests --- R/generateZerosUsingSL.R | 11 +++-- tests/testthat/test-generateZerosUsingSL.R | 50 ++++++++++++---------- 2 files changed, 36 insertions(+), 25 deletions(-) diff --git a/R/generateZerosUsingSL.R b/R/generateZerosUsingSL.R index 86a9967..edc4f7e 100644 --- a/R/generateZerosUsingSL.R +++ b/R/generateZerosUsingSL.R @@ -41,6 +41,8 @@ generateZerosUsingSL <- function(x, tmpSA$SSspecListName <- x$SS$SSspecListName[match(aux$SSid[match(tmpSA$SAid,aux$SAid)], x$SS$SSid)] tmpSA$DEyear <- x$DE$DEyear[match(aux$DEid[match(tmpSA$SAid,aux$SAid)], x$DE$DEid)] tmpSA$SScatchFra <- x$SS$SScatchFra[match(aux$SSid[match(tmpSA$SAid,aux$SAid)], x$SS$SSid)] + tmpSA$SLid<-x$SS$SLid[match(aux$SSid[match(tmpSA$SAid,aux$SAid)], x$SS$SSid)] + tmpSA$SLspeclistName<-x$SL$SLspeclistName[match(tmpSA$SLid, x$SL$SLid)] tmpSA[ ,tmpKey := paste(DEyear, SDctry, SDinst, SSspecListName, SScatchFra, SAspeCode)] @@ -57,12 +59,12 @@ colsToDelete<-c("SDctry", "SDinst","SSspecListName","DEyear","SScatchFra") ,.N, .(SSid,SAstratumName)]$N>1)) stop("cannot generateZerosUsingSL because >1 SAcatchCat OR SAsex OR SAlandCat in same SSid*SAstratumName: situation still to be analyzed - likely you should have them ") - + ls1 <- split(tmpSA, paste(tmpSA$SSid, tmpSA$SAstratumName)) ls2 <- lapply(ls1, function(x) { - for (w in tmpSL$tmpKey) { + for (w in tmpSL$tmpKey[tmpSL$SLspeclistName==x$SLspeclistName]) { if (!w %in% tmpSA$tmpKey) { - # duplicates SA row + # duplicates SA row y <- x[1, ] # handles the key y$SAspeCode <- as.integer(unlist(strsplit(w," "))[6]) @@ -98,6 +100,9 @@ colsToDelete<-c("SDctry", "SDinst","SSspecListName","DEyear","SScatchFra") x }) x[["SA"]] <- data.table::setDT(do.call("rbind", ls2)) + # delete aux var + x[["SA"]]$SLspeclistName<-NULL + x[["SA"]]$SLid<-NULL # Ensure key is set on SA setkey(x[["SA"]],SAid) x diff --git a/tests/testthat/test-generateZerosUsingSL.R b/tests/testthat/test-generateZerosUsingSL.R index 9902a4c..39c5b00 100644 --- a/tests/testthat/test-generateZerosUsingSL.R +++ b/tests/testthat/test-generateZerosUsingSL.R @@ -7,33 +7,36 @@ test_that("generateZerosUsingSL creates rows for SLcou*SLinst*SLspeclistName*SLy myH1DataObject <- RDBEScore:::importRDBESDataZIP("./h1_v_1_19_18/ZW_1965_WGRDBES-EST_TEST_1.zip") # Only use a subset of the test data - myH1DataObject <- filterRDBESDataObject(myH1DataObject,c("DEstratumName"),c("Pckg_survey_apistrat_H1")) - myH1DataObject <- filterRDBESDataObject(myH1DataObject,c("SLspeclistName"),c("WGRDBES-EST_TEST_1_Pckg_survey_apistrat_H1")) - myH1DataObject <- findAndKillOrphans(myH1DataObject) + myH1DataObject0 <- filterRDBESDataObject(myH1DataObject,c("DEstratumName"),c("Pckg_survey_apistrat_H1")) + myH1DataObject0 <- filterRDBESDataObject(myH1DataObject0,c("SLspeclistName"),c("WGRDBES-EST_TEST_1_Pckg_survey_apistrat_H1")) + myH1DataObject0 <- findAndKillOrphans(myH1DataObject0) - validateRDBESDataObject(myH1DataObject, checkDataTypes = TRUE) + validateRDBESDataObject(myH1DataObject0, checkDataTypes = TRUE) - df1 <- data.frame('31831','SL','ZW','4484',myH1DataObject[["SL"]]$SLspeclistName,'1965','Dis','107254','107254') + df1 <- data.frame('31831','SL','ZW','4484',myH1DataObject0[["SL"]]$SLspeclistName,'1965','Dis','107254','107254') - colnames(df1) <- names(myH1DataObject[["SL"]]) - myH1DataObject[["SL"]] <- rbind(myH1DataObject[["SL"]],df1) - myH1DataObject[["SL"]]$SLid <- as.integer(myH1DataObject[["SL"]]$SLid) - myH1DataObject[["SL"]]$SLyear <- as.integer(myH1DataObject[["SL"]]$SLyear) - myH1DataObject[["SL"]]$SLcommTaxon <- as.integer(myH1DataObject[["SL"]]$SLcommTaxon) - myH1DataObject[["SL"]]$SLsppCode <- as.integer(myH1DataObject[["SL"]]$SLsppCode) + colnames(df1) <- names(myH1DataObject0[["SL"]]) + myH1DataObject0[["SL"]] <- rbind(myH1DataObject0[["SL"]],df1) + myH1DataObject0[["SL"]]$SLid <- as.integer(myH1DataObject0[["SL"]]$SLid) + myH1DataObject0[["SL"]]$SLyear <- as.integer(myH1DataObject0[["SL"]]$SLyear) + myH1DataObject0[["SL"]]$SLcommTaxon <- as.integer(myH1DataObject0[["SL"]]$SLcommTaxon) + myH1DataObject0[["SL"]]$SLsppCode <- as.integer(myH1DataObject0[["SL"]]$SLsppCode) + # add an additional species list - could be many in the SL download + myH1DataObject0[["SL"]]<-rbind(myH1DataObject0[["SL"]], myH1DataObject[["SL"]][1,]) + # ensure key is set on SL - setkey(myH1DataObject[["SL"]], SLid) + setkey(myH1DataObject0[["SL"]], SLid) - myH1DataObject[["SS"]]<-rbind(myH1DataObject[["SS"]][1,],myH1DataObject[["SS"]][1,]) - myH1DataObject[["SS"]]$SScatchFra[2]<-"Dis" - myH1DataObject[["SS"]]$SSid[2]<-myH1DataObject[["SS"]]$SSid[1]+1 - myH1DataObject[["SS"]]$SSid<-as.integer(myH1DataObject[["SS"]]$SSid) + myH1DataObject0[["SS"]]<-rbind(myH1DataObject0[["SS"]][1,],myH1DataObject0[["SS"]][1,]) + myH1DataObject0[["SS"]]$SScatchFra[2]<-"Dis" + myH1DataObject0[["SS"]]$SSid[2]<-myH1DataObject0[["SS"]]$SSid[1]+1 + myH1DataObject0[["SS"]]$SSid<-as.integer(myH1DataObject0[["SS"]]$SSid) # ensure key is set on SS - setkey(myH1DataObject[["SS"]], SSid) + setkey(myH1DataObject0[["SS"]], SSid) - myH1DataObject1 <- filterRDBESDataObject(myH1DataObject, c("SAid"), c(572813), killOrphans = TRUE) - validateRDBESDataObject(myH1DataObject, checkDataTypes = TRUE) + myH1DataObject1 <- filterRDBESDataObject(myH1DataObject0, c("SAid"), c(572813), killOrphans = TRUE) + validateRDBESDataObject(myH1DataObject0, checkDataTypes = TRUE) validateRDBESDataObject(myH1DataObject1, checkDataTypes = TRUE) # species*catchFrac in SL and not in SA: expected behavior -> generate a 0 row in SA @@ -43,6 +46,9 @@ test_that("generateZerosUsingSL creates rows for SLcou*SLinst*SLspeclistName*SLy # create aux id_table [Nuno's function] and tmpKey to use in test aux<-createTableOfRDBESIds(x = myTest3, addSAseqNums=FALSE) + + # will be unequal is species lists not applicable to samples not correctly handled + expect_equal(nrow(myTest3$SA),length(myTest3$SS$SLid[match(aux$SSid[match(myTest3$SS$SSid,aux$SSid)], myTest3$SS$SSid)])) myTest3$SA$SLid <- myTest3$SS$SLid[match(aux$SSid[match(myTest3$SS$SSid,aux$SSid)], myTest3$SS$SSid)] myTest3$SL <- myTest3$SL[myTest3$SL$SLid %in% myTest3$SA$SLid, ] @@ -118,17 +124,17 @@ test_that("generateZerosUsingSL creates rows for SLcou*SLinst*SLspeclistName*SLy # explanation: # in a normal situation these variables are filled in the new from the 1st row of SSid*SAstratumName # if it happens that there are >1 values in that SSid*SAstratumName this is not valid - an error is issued - myH1DataObject2<-myH1DataObject + myH1DataObject2<-myH1DataObject0 myH1DataObject2$SA$SSid[1]<-myH1DataObject2$SA$SSid[2] myH1DataObject2$SA$SAcatchCat[1]<-"Dis" expect_error(generateZerosUsingSL(myH1DataObject2)) - myH1DataObject2<-myH1DataObject + myH1DataObject2<-myH1DataObject0 myH1DataObject2$SA$SSid[1]<-myH1DataObject2$SA$SSid[2] myH1DataObject2$SA$SAsex[1]<-"F" expect_error(generateZerosUsingSL(myH1DataObject2)) - myH1DataObject2<-myH1DataObject + myH1DataObject2<-myH1DataObject0 myH1DataObject2$SA$SSid[1]<-myH1DataObject2$SA$SSid[2] myH1DataObject2$SA$SAlandCat[1]<-"HuC" expect_error(generateZerosUsingSL(myH1DataObject2))