diff --git a/.Rbuildignore b/.Rbuildignore index c38c689f..075e34a3 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,3 +1,5 @@ +^renv$ +^renv\.lock$ ^.*\.Rproj$ ^\.Rproj\.user$ ^data-raw$ @@ -17,3 +19,5 @@ package_overview.Rmd ^.pptx$ ^_pkgdown\.yml$ ^pkgdown$ +^\.positai$ +^\.claude$ diff --git a/.gitignore b/.gitignore index 428307b6..161f3e72 100644 --- a/.gitignore +++ b/.gitignore @@ -33,14 +33,17 @@ FishNCo/testData/RegionalTestData/* ~$* /doc/ /Meta/ -<<<<<<< Updated upstream .vscode/ docs -======= # Data to develop fun /NLdata/ ->>>>>>> Stashed changes package_overview.tex package_overview.html package_overview.pptx package_overview.md + +# add renv stuff +/renv/ +.Rprofile +renv.lock +.positai diff --git a/DESCRIPTION b/DESCRIPTION index 972c2d39..92062517 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,124 +1,124 @@ Package: RDBEScore Type: Package Title: Functions for the ICES Regional Database and Estimation System (RDBES) -Version: 0.3.5 +Version: 0.4.0 Author: c( - person(given = "David", - family = "Currie", - role = c("aut"), + person(given = "David", + family = "Currie", + role = c("aut"), comment = c(ORCID = "0000-0002-3523-6895")), person(given = "Richard", family = "Meitern", role = c("aut"), email = "richard.meitern@ut.ee", comment = c(ORCID = "0000-0002-2600-3002")), - person(given = "Nuno", - family = "Prista", - role = c("aut"), - email = "nuno.prista@slu.se", + person(given = "Nuno", + family = "Prista", + role = c("aut"), + email = "nuno.prista@slu.se", comment = c(ORCID = "0000-0002-5145-7241")), - person(given = "Nicholas", - family = "Carey", + person(given = "Nicholas", + family = "Carey", role = c("aut"), email = "nicholas.carey@gov.scot"), - person(given = "Petri", - family = "Sarvamaa", - role = c("aut"), + person(given = "Petri", + family = "Sarvamaa", + role = c("aut"), email = "Petri.Sarvamaa@luke.fi"), - person(given = "Kirsten", - family = "Birch Håkansson", - role = c("aut"), + person(given = "Kirsten", + family = "Birch Håkansson", + role = c("aut"), email = "kih@aqua.dtu.dk"), - person(given = "Karolina", - family = "Molla Gazi", - role = c("aut"), - email = "karolina.mollagazi@wur.nl"), - person(given = "Julia", - family = "Wischnewski", - role = c("aut"), - email = "julia.wischnewski@thuenen.de"), - person(given = "Ana Cláudia", - family = "Fernandes", - role = c("aut"), + person(given = "Karolina", + family = "Molla Gazi", + role = c("aut"), + email = "karolina.mollagazi@wur.nl"), + person(given = "Julia", + family = "Wischnewski", + role = c("aut"), + email = "julia.wischnewski@thuenen.de"), + person(given = "Ana Cláudia", + family = "Fernandes", + role = c("aut"), email = "acfernandes@ipma.pt"), - person(given = "Katarzyna", - family = "Krakówka", - role = c("aut"), + person(given = "Katarzyna", + family = "Krakówka", + role = c("aut"), email = "kkrakowka@mir.gdynia.pl"), - person(given = "Marta", - family = "Szymańska", - role = c("aut"), - email = "msuska@mir.gdynia.pl"), - person(given = "Nicolas", - family = "Goñi", - role = c("aut"), - email = "nicolas.goni@luke.fi"), - person(given = "Annica", - family = "de Groote", - role = c("ctb"), - email = "annica.isaksson.de.groote@slu.se"), - person(given = "Jonathan", - family = "Ball", - role = c("ctb"), + person(given = "Marta", + family = "Szymańska", + role = c("aut"), + email = "msuska@mir.gdynia.pl"), + person(given = "Nicolas", + family = "Goñi", + role = c("aut"), + email = "nicolas.goni@luke.fi"), + person(given = "Annica", + family = "de Groote", + role = c("ctb"), + email = "annica.isaksson.de.groote@slu.se"), + person(given = "Jonathan", + family = "Ball", + role = c("ctb"), email = "johnathan.ball@cefas.co.uk"), - person(given = "Jonathan", - family = "Rault", - role = c("ctb"), + person(given = "Jonathan", + family = "Rault", + role = c("ctb"), email = "Jonathan.Rault@ifremer.fr"), - person(given = "Antti", - family = "Sykkö", - role = c("ctb"), + person(given = "Antti", + family = "Sykkö", + role = c("ctb"), email = "antti.sykko@luke.fi"), - person(given = "Liz", - family = "Clarke", - role = c("ctb"), + person(given = "Liz", + family = "Clarke", + role = c("ctb"), email = "Liz.Clarke@gov.scot"), - person(given = "Chun", - family = "Chen", - role = c("ctb"), + person(given = "Chun", + family = "Chen", + role = c("ctb"), email = "chun.chen@wur.nl"), - person(given = "Hongru", - family = "Zhai", - role = c("ctb"), + person(given = "Hongru", + family = "Zhai", + role = c("ctb"), email = "hongru.zhai@slu.se"), - person(given = "Eros", - family = "Quesada", - role = c("ctb"), + person(given = "Eros", + family = "Quesada", + role = c("ctb"), email = "eros.quesada@slu.se"), - person(given = "Jonathan", - family = "Stounberg", - role = c("ctb"), + person(given = "Jonathan", + family = "Stounberg", + role = c("ctb"), email = "jostou@aqua.dtu.dk"), - person(given = "Ana", - family = "Ribeiro Santos", - role = c("ctb"), + person(given = "Ana", + family = "Ribeiro Santos", + role = c("ctb"), email = "ana.ribeirosantos@cefas.co.uk"), - person(given = "Jose", - family = "Castro", - role = c("ctb"), - email = "jose.castro@ieo.es"), - person(given = "Jessica", - family = "Craig", - role = c("ctb"), - email = "Jessica.Craig@gov.scot") - ) -Maintainer: Colin Millar -Description: The RDBEScore package provides functions to import and work with - fisheries data downloaded from the ICES RDBES database. It also contains - functions to perform estimation analysis using the resulting objects. + person(given = "Jose", + family = "Castro", + role = c("ctb"), + email = "jose.castro@ieo.es"), + person(given = "Jessica", + family = "Craig", + role = c("ctb"), + email = "Jessica.Craig@gov.scot"), + person(given = "Colin", family = "Millar", role = "ctb"), + person(given = "Ejaz", family = "Muhammad", role = "ctb")) +Maintainer: Richard Meitern +Description: The RDBEScore package provides functions to import and work with + fisheries data downloaded from the ICES RDBES database. It also contains + functions to perform estimation analysis using the resulting objects. URL: https://github.com/ices-tools-dev/RDBEScore, https://rdbes.ices.dk, https://ices-tools-dev.github.io/RDBEScore/ License: GPL-3 + file LICENSE Encoding: UTF-8 LazyData: true -RoxygenNote: 7.3.2 Roxygen: list(markdown = TRUE) -Suggests: +Suggests: knitr, rmarkdown, testthat -Depends: +Depends: R (>= 4.1) -Imports: - dplyr (>= 1.1.3), +Imports: data.table VignetteBuilder: knitr +Config/roxygen2/version: 8.1.1 diff --git a/NAMESPACE b/NAMESPACE index d8eab868..d92cd126 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,7 @@ export(createRDBESDataObject) export(createRDBESEstObject) export(doBVestimCANUM) export(doEstimationForAllStrata) +export(doEstimationRatio) export(estim) export(estimMC) export(exportEstimationResultsToInterCatchFormat) @@ -34,10 +35,14 @@ export(updateSAwithTaxonFromSL) export(validateRDBESDataObject) export(validateRDBESEstObject) import(data.table) -importFrom(stats,formula) -importFrom(stats,na.omit) -importFrom(stats,rnorm) -importFrom(stats,setNames) -importFrom(utils,file_test) -importFrom(utils,packageDescription) -importFrom(utils,tail) +importFrom(stats, + formula, + na.omit, + rnorm, + setNames +) +importFrom(utils, + file_test, + packageDescription, + tail +) diff --git a/NEWS.md b/NEWS.md index fe60ad83..e19f2e4b 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +# RDBEScore 0.4.0 +- Breaking: `getLinkedDataFromLevel()` now returns the requested field and target-table columns in both directions, without adding intermediate hierarchy ids (#268). Non-id requested fields are retained when going down the hierarchy. `getLowerTableSubsets()` avoids duplicated requested-field columns. +- Package README updated with AI usage guidelines +- Dependencies: removed `dplyr` from Imports. Joins now use the internal `data.table` helper `joinDT()`, which keeps dplyr's row order, column order and `.x`/`.y` suffixes, so results are unchanged; `filterRDBESEstObject()` and the vignette use base R/`data.table` instead of dplyr. +- Bug fix: addressed [#259](https://github.com/ices-tools-dev/RDBEScore/issues/259) selecting multiple strata with `addCLtoLowerCS()` + # RDBEScore 0.3.5 - Bug fix: addressed [#251](https://github.com/ices-tools-dev/RDBEScore/issues/251). diff --git a/R/addCLtoLowerCS.R b/R/addCLtoLowerCS.R index 8d3062ea..fad64891 100644 --- a/R/addCLtoLowerCS.R +++ b/R/addCLtoLowerCS.R @@ -47,7 +47,7 @@ addCLtoLowerCS <- function(rdbes, strataListCS, strataListCL, combineStrata =T, # Function to subset data.table based on criteria list subset_dt <- function(dt, criteria) { for (field in names(criteria)) { - dt <- dt[get(field) == criteria[[field]], ] + dt <- dt[get(field) %in% criteria[[field]], ] } return(dt) } diff --git a/R/combineRDBESDataObjects.R b/R/combineRDBESDataObjects.R index 9bfc7cb0..0557bdee 100644 --- a/R/combineRDBESDataObjects.R +++ b/R/combineRDBESDataObjects.R @@ -22,15 +22,12 @@ #' #' @examples #' \dontrun{ -#' -#' myH1RawObject <- -#' importRDBESDataCSV(rdbesExtractPath = "tests\\testthat\\h1_v_1_19") -#' myH5RawObject <- -#' importRDBESDataCSV(rdbesExtractPath = "tests\\testthat\\h5_v_1_19") -#' -#' myCombinedRawObject <- combineRDBESDataObjects(RDBESDataObject1=myH1RawObject, -#' RDBESDataObject2=myH5RawObject) -#' } +#' myH1DataObject <- H1Example +#' myH5DataObject <- H5Example +#' myCombinedRawObject <- combineRDBESDataObjects(RDBESDataObject1=myH1DataObject, +#' RDBESDataObject2=myH5DataObject) +#' myCombinedRawObject <- combineRDBESDataObjects(RDBESDataObject1=myH1DataObject, +#' RDBESDataObject2=myH5DataObject, strict=F)} RDBESDataObject2=myH5RawObject) combineRDBESDataObjects <- function(RDBESDataObject1, RDBESDataObject2, verbose = FALSE, diff --git a/R/createDBEPrepObj.R b/R/createDBEPrepObj.R index 4c92e69f..0fd894e0 100644 --- a/R/createDBEPrepObj.R +++ b/R/createDBEPrepObj.R @@ -12,7 +12,7 @@ #' input <- "WKRDB-EST2/testData/output/DBErawObj/" #' output <- "WKRDB-EST2/subGroup1/personal/John/PreparedOutputs/" #' -#' createDBEPrepObj(input = input, output = output) +#' RDBEScore:::createDBEPrepObj(input = input, output = output) #' } createDBEPrepObj <- function(input, output) { diff --git a/R/createRDBESEstObject.R b/R/createRDBESEstObject.R index 4bdd7597..700f7d80 100644 --- a/R/createRDBESEstObject.R +++ b/R/createRDBESEstObject.R @@ -18,6 +18,11 @@ #' #' @return An object of class RDBESEstObject ready for use in design based #' estimation +#' +#' @section Development review: +#' - AI-assisted: No +#' - Human review: rix133 +#' #' @export #' #' @examples @@ -212,7 +217,7 @@ createRDBESEstObject <- function(rdbesPrepObject, # (much faster than the recursive "getSubSampleLevel()" function it was using before) lookupDT <- prepareSubSampleLevelLookup(SAdata) # Apply it - subSampleLevels <- dplyr::left_join(SAdata, lookupDT, by = "SAid") + subSampleLevels <- joinDT(SAdata, lookupDT, by = "SAid") subSampleLevels <- subSampleLevels[,c("SAid","topLevelSAid","subSampleLevel")] rdbesPrepObjectCopy[["SA"]][, "SAtopLevelSAid"] <- @@ -330,11 +335,9 @@ createRDBESEstObject <- function(rdbesPrepObject, # Use a left join on the deepest level of sampling so that we # get all the upper hierarchy rows if (j == numberOfSampleLevels) { - tempRDBESEstObj <- dplyr::left_join(tempUpper, + tempRDBESEstObj <- joinDT(tempUpper, tempLower, - by = saJoinField, - multiple = "all" - + by = saJoinField ) } else { @@ -366,10 +369,10 @@ createRDBESEstObject <- function(rdbesPrepObject, # Use an inner join on the # currnt SA level so that we just get the matching rows - tempRDBESEstObj <- dplyr::inner_join(tempUpper, + tempRDBESEstObj <- joinDT(tempUpper, tempLower, by = saJoinField, - multiple = "all" + type = "inner" ) } if (verbose) { @@ -482,10 +485,9 @@ gc() gc() # if we have both FM and BV data - join them together fMBV <- - dplyr::left_join(rdbesPrepObject[["FM"]], + joinDT(rdbesPrepObject[["FM"]], rdbesPrepObject[["BV"]], - by = "FMid", - multiple = "all" + by = "FMid" ) gc() # sort out the wrong SAid column name after the join @@ -522,10 +524,10 @@ gc() } else { gc() # if we have both FM and BV data - join them together - bVFM <- dplyr::right_join(rdbesPrepObject[["FM"]], + bVFM <- joinDT(rdbesPrepObject[["FM"]], rdbesPrepObject[["BV"]], by = "FMid", - multiple = "all" + type = "right" ) # sort out the wrong SAid column name after the join names(bVFM)[names(bVFM) == "SAid.y"] <- "SAid" @@ -547,16 +549,16 @@ gc() # If we have data join our lowerX with the fmBV or BVFm data if (!is.null(nrow(fMBV))){ - lowerA <- dplyr::left_join(lowerA, fMBV, by = "SAid", multiple = "all") - lowerB <- dplyr::left_join(lowerB, fMBV, by = "SAid", multiple = "all") - #lowerD <- dplyr::left_join(lowerD, fMBV, by = "SAid") + lowerA <- joinDT(lowerA, fMBV, by = "SAid") + lowerB <- joinDT(lowerB, fMBV, by = "SAid") + #lowerD <- joinDT(lowerD, fMBV, by = "SAid") lowerD <- NULL allLower <- rbind(allLower,lowerA, lowerB, lowerD) } if (!is.null(nrow(bVFM))){ # Note the difference in lowerC - lowerC <- dplyr::left_join(lowerC, bVFM, by = "SAid", multiple = "all") + lowerC <- joinDT(lowerC, bVFM, by = "SAid") allLower <- rbind(allLower,lowerC) } @@ -668,19 +670,12 @@ gc() } gc() # Join this new table to the existing data + # (joinDT keeps the columns and rows in the order of myRDBESEstObj) myRDBESEstObj <- - dplyr::left_join(myRDBESEstObj, + joinDT(myRDBESEstObj, rdbesPrepObject[[thisTable]], by = joinField - , multiple = "all" ) - # TODO Should be able to use data.table to do a left join instead of dplyr - # but the two lines below were both wrong. The first gives the columns back in the - # wrong order. The second gives the columns in the right order but doesn't - # include all the rows :-( - #myRDBESEstObj <- rdbesPrepObject[[thisTable]][myRDBESEstObj, on = joinField] - # (the order of the tables is to ensure the columns are returned in the right order) - #myRDBESEstObj <- myRDBESEstObj[rdbesPrepObject[[thisTable]], on = joinField] } gc() # recursively call this function diff --git a/R/createTableOfRDBESIds.r b/R/createTableOfRDBESIds.r index 434803ae..34df0034 100644 --- a/R/createTableOfRDBESIds.r +++ b/R/createTableOfRDBESIds.r @@ -12,12 +12,9 @@ #' #' @examples #' \dontrun{ +#' myH1DataObject <- H1Example +#' myTableOfIds <- RDBEScore:::createTableOfRDBESIds(myH1DataObject)} #' -#' myH1RawObject <- -#' importRDBESDataCSV(rdbesExtractPath = "tests\\testthat\\h1_v_1_19_13") -#' -#' myTableOfIds<- createTableOfRDBESIds(myH1RawObject) -#' } createTableOfRDBESIds<-function(x, addSAseqNums=TRUE){ diff --git a/R/data.R b/R/data.R index affcc6cf..f2dd08a2 100644 --- a/R/data.R +++ b/R/data.R @@ -156,7 +156,7 @@ #' \item{IS}{the Individual Species table} #' } -#' #' @source Richard Meitern @ Estonian Marine Institute, 2025 +#' @source Richard Meitern @ Estonian Marine Institute, 2025 "H7Example" #' A dataset containing test RDBES data for H8 in the RDBESDataObject structure @@ -182,7 +182,7 @@ #' \item{CL}{the Commertial Landing data table} #' \item{CE}{the Commertial Effort data table} #' } -#' #' @source Richard Meitern @ Estonian Marine Institute, 2025 +#' @source Richard Meitern @ Estonian Marine Institute, 2025 "H8ExampleEE1" #' A dataset containing test RDBES data for H5 in the RDBESDataObject structure @@ -234,7 +234,62 @@ #' @source \url{https://CRAN.R-project.org/package=survey} "Pckg_survey_apiclus2_H1" +#' A RDBESDataObject converted from package survey dataset apiclus1 +#' +#' This data set is derived from the Academic Performance Index computed for all +#' California schools based on standardized testing of students. The original +#' data sets contain information for all schools with at least 100 students and +#' for various probability samples of the data. The design is 1-stage cluster +#' sampling with clusters of unequal sizes. An SRS of 15 districts is selected +#' (psus) from the 757 districts in the population. All schools within district +#' are selected (ssus). The weights (pw) do not match 757/15 probably because +#' they have been calibrated. The target variable is enroll. +#' +#' @format A list containing entries required for H1 RDBES data: +#' \describe{ +#' \item{DE}{the Design data table. Contains 1 DE row with DEstratumName == "Pckg_SDAResources_apiclus1_v2_H1"} +#' \item{SD}{the Sampling Details data table. Contains 1 child SD row} +#' \item{VS}{the Vessel Selection data table. Contains 183 child rows (the 186 schools finally observed), each associated to its cluster (dname), VSnumberTotalClusters is 757, VSnumberTotal is the number of schools in the cluster (census), calibrated weights are provided as 1/pw in VSinclusionProbCluster} +#' \item{FT}{the Fishing Trip data table. Just 1:1 links to the final data (in SA)} +#' \item{FO}{the Fishing Operation data table. Just 1:1 links to the final data (in SA)} +#' \item{SS}{the Species Selection data table. Just 1:1 links to the final data (in SA)} +#' \item{SA}{the Sample data table. SAsampleWeightMeasured is enroll} +#' \item{FM}{the Frequency Measure data table} +#' \item{BV}{the Biological Variable data table} +#' \item{VD}{the Vessel Details data table} +#' \item{SL}{the Species List data table} +#' \item{IS}{the Individual Species table} +#' } +#' @source \url{https://CRAN.R-project.org/package=survey} +"Pckg_survey_apiclus1_H1" +#' A Clustered RDBESDataObject converted from package survey dataset apiclus2 +#' +#' This data set is derived from the Academic Performance Index computed for all +#' California schools based on standardized testing of students. The original +#' data sets contain information for all schools with at least 100 students and +#' for various probability samples of the data. The design is 2-stage cluster +#' sampling with clusters of unequal sizes. An SRS of 40 districts is selected +#' (psus) from the 757 districts in the population and then up to 5 schools (min +#' 1) were selected from each district (ssus). The target variable is enroll - note that it contains 4 NA values. +#' +#' @format A list containing entries required for H1 RDBES data: +#' \describe{ +#' \item{DE}{the Design data table. Contains 1 DE row with DEstratumName == "Pckg_SDAResources_apiclus2_v2_H1"} +#' \item{SD}{the Sampling Details data table. Contains 1 child SD row} +#' \item{VS}{the Vessel Selection data table. Contains 126 child rows (the 126 schools finally observed), each associated to its cluster (dname), VSnumberTotalClusters is 757, VSnumberTotal is 1...5 schools sampled} +#' \item{FT}{the Fishing Trip data table. Just 1:1 links to the final data (in SA)} +#' \item{FO}{the Fishing Operation data table. Just 1:1 links to the final data (in SA)} +#' \item{SS}{the Species Selection data table. Just 1:1 links to the final data (in SA)} +#' \item{SA}{the Sample data table. SAsampleWeightMeasured is enroll (note the 4 NAs)} +#' \item{FM}{the Frequency Measure data table} +#' \item{BV}{the Biological Variable data table} +#' \item{VD}{the Vessel Details data table} +#' \item{SL}{the Species List data table} +#' \item{IS}{the Individual Species table} +#' } +#' @source \url{https://CRAN.R-project.org/package=survey} +"Pckg_survey_apiclus2_v2_H1" #' A RDBESDataObject converted from package survey dataset apistrat #' @@ -270,6 +325,46 @@ ##------H1 Data from SDAResources package------------------- +#' A RDBESDataObject converted from package SDAResources dataset agsrs +#' +#' This data set is derived from the data(agsrs) used in Lohr examples 2.6, 2.7 +#' and 2.11 of SDA book. Information required for example 4.8 +#' (domain estimation) is also added to SA (farmcat <=> SAarea). +#' VSnumberSampled and VSnumberTotal set according to agsrs and book pop +#' values. VSunitName is set to a combination of original agsrs$county, +#' agsrs$state, agsrs$region and row numbers. Table SA contains the variable +#' measured agsrs$acres92 in SAtotalWeightMeasured, SAsampleWeightMeasured and +#' SAconversionFactorMeasLive set to 1. Table SA also contains the domain +#' information, coded in SAarea. Table DE, SD, FT and FO are for the most +#' dummy tables inserted to meet RDBES model requirements to be aggregated +#' during estimation tests. Values of mandatory fields have dummy values with +#' exception of Design-Variables in VS that match the book. BV, FM, CL, and CE +#' are not provided. SL and VD are subset to the essential rows. +#' +#' @format A list containing entries required for H1 RDBES data: +#' \describe{ +#' \item{DE}{the Design data table. Contains dummy values with exception of +#' Design-Variables in VS that match the book} +#' \item{SD}{the Sampling Details data table. Contains dummy values} +#' \item{VS}{the Vessel Selection data table. Contains core information of +#' data(agsrs), VSnumberSampled and VSnumberTotal set according to agsrs +#' and book pop values, VSunitName is set to a combination of original +#' agsrs$county, agsrs$state, agsrs$region and row numbers} +#' \item{FT}{the Fishing Trip data table. Contains dummy values} +#' \item{FO}{the Fishing Operation data table. Contains dummy values} +#' \item{SS}{the Species Selection data table. Contains dummy values} +#' \item{SA}{the Sample data table. Contains the variable measured +#' agsrs$acres92 in SAtotalWeightMeasured, SAsampleWeightMeasured and +#' SAconversionFactorMeasLive set to 1, and the domain information, +#' coded in SAarea} +#' \item{FM}{the Frequency Measure data table. Not provided} +#' \item{BV}{the Biological Variable data table. Not provided} +#' \item{VD}{the Vessel Details data table. Subset to the essential rows} +#' \item{SL}{the Species List data table. Subset to the essential rows} +#' \item{IS}{the Individual Species table} +#' } +#' @source \url{https://CRAN.R-project.org/package=SDAResources} +"Pckg_SDAResources_agsrs_H1" #' A RDBESDataObject converted from package SDAResources dataset agstrat #' @@ -311,64 +406,175 @@ #' @source \url{https://CRAN.R-project.org/package=SDAResources} "Pckg_SDAResources_agstrat_H1" +#' A RDBESDataObject converted from package SDAResources dataset algebra +#' +#' This data set is derived from a fictional data for an SRS of 12 algebra +#' classes in a city, from a population of 187 classes. The design is 1-stage +#' cluster sampling with clusters of unequal sizes. Clusters are classes (class). +#' Clusters (psu) are unequal sized (Mi). In each cluster, all students are +#' selected (ssus, nrows). The total number of psus is known (187). The target +#' variable is score. +#' +#' @format A list containing entries required for H1 RDBES data: +#' \describe{ +#' \item{DE}{the Design data table. Contains 1 DE row with +#' DEstratumName == "Pckg_SDAResources_algebra_H1"} +#' \item{SD}{the Sampling Details data table. Contains 1 child SD row} +#' \item{VS}{the Vessel Selection data table. Contains 299 child rows +#' (the 299 students observed), each associated to its cluster (class), +#' VSnumberTotalClusters is 187, VSnumberSampledClusters is 12, +#' VSnumberTotal is Missing} +#' \item{FT}{the Fishing Trip data table. Just 1:1 links to the final +#' data (in SA)} +#' \item{FO}{the Fishing Operation data table. Just 1:1 links to the final +#' data (in SA)} +#' \item{SS}{the Species Selection data table. Just 1:1 links to the final +#' data (in SA)} +#' \item{SA}{the Sample data table. Each score is a SAsampleWeightMeasured} +#' \item{FM}{the Frequency Measure data table} +#' \item{BV}{the Biological Variable data table} +#' \item{VD}{the Vessel Details data table} +#' \item{SL}{the Species List data table} +#' \item{IS}{the Individual Species table} +#' } +#' @source \url{https://CRAN.R-project.org/package=SDAResources} +"Pckg_SDAResources_algebra_H1" + +#' A RDBESDataObject converted from package SDAResources dataset coots +#' +#' This data set is derived from the data(coots). The design is 2-stage cluster +#' sampling with clusters of unequal sizes and Npsu not known. Clusters are +#' clutches of eggs (nests) with at least 2 eggs. In each cluster, the volume +#' of two eggs is measured. Clusters (psu) are unequal sized. In each cluster, +#' 2 eggs are selected (ssus) and measured. The total number of psus is not +#' known (a drawback in this example). It is assumed very large (fpc negligible). +#' The target variable is volume (others are available). +#' +#' @format A list containing entries required for H1 RDBES data: +#' \describe{ +#' \item{DE}{the Design data table. Contains 1 DE row with +#' DEstratumName == "Pckg_SDAResources_coots_H1"} +#' \item{SD}{the Sampling Details data table. Contains 1 child SD row} +#' \item{VS}{the Vessel Selection data table. Contains 368 child rows +#' (the 368 eggs/psus observed), each associated to its cluster (clutch), +#' VSnumberTotalClusters is not known, VSnumberTotal is csize} +#' \item{FT}{the Fishing Trip data table. Just 1:1 links to the final data +#' (in SA)} +#' \item{FO}{the Fishing Operation data table. Just 1:1 links to the final +#' data (in SA)} +#' \item{SS}{the Species Selection data table. Just 1:1 links to the +#' final data (in SA)} +#' \item{SA}{the Sample data table. Each volume is a SAsampleWeightMeasured. +#' ATT volumes are *100000000 to meet type requirement (integer)} +#' \item{FM}{the Frequency Measure data table} +#' \item{BV}{the Biological Variable data table} +#' \item{VD}{the Vessel Details data table} +#' \item{SL}{the Species List data table} +#' \item{IS}{the Individual Species table} +#' } +#' @source \url{https://CRAN.R-project.org/package=SDAResources} +"Pckg_SDAResources_coots_H1" +#' A Multi-stage RDBESDataObject from package SDAResources dataset coots +#' +#' This data set is derived from the data(coots). The design is 2-stage cluster +#' sampling with clusters of unequal sizes and Npsu not known. Clusters are +#' clutches of eggs (nests) with at least 2 eggs. In each cluster, the volume +#' of two eggs is measured. Clusters (psu) are unequal sized. In each cluster, +#' 2 eggs are selected (ssus) and measured. The total number of psus is not +#' known (a drawback in this example). It is assumed very large (fpc negligible). +#' The target variable is volume. +#' +#' @format A list containing entries required for H1 RDBES data: +#' \describe{ +#' \item{DE}{the Design data table. Contains 1 DE row with +#' DEstratumName == "Pckg_SDAResources_coots_H1"} +#' \item{SD}{the Sampling Details data table. Contains 1 child SD row} +#' \item{VS}{the Vessel Selection data table. Contains 184 child rows +#' (the 184 clutches/psus observed), each associated to its cluster (clutch), +#' VSnumberTotal is not known, VSnumberSampled is 184} +#' \item{FT}{the Fishing Trip data table. Contains 368 child rows +#' (the 368 eggs/ssus measured), each associated to its vessel (clutch), +#' FTnumbersampled is 2, FTnumberTotal is csize} +#' \item{FO}{the Fishing Operation data table. Just 1:1 links to the final +#' data (in SA)} +#' \item{SS}{the Species Selection data table. Just 1:1 links to the final +#' data (in SA)} +#' \item{SA}{the Sample data table. Each volume is a SAsampleWeightMeasured. +#' ATT volumes are *100000000 to meet type requirement (integer)} +#' \item{FM}{the Frequency Measure data table} +#' \item{BV}{the Biological Variable data table} +#' \item{VD}{the Vessel Details data table} +#' \item{SL}{the Species List data table} +#' \item{IS}{the Individual Species table} +#' } +#' @source \url{https://CRAN.R-project.org/package=SDAResources} +"Pckg_SDAResources_coots_multistage_H1" + +#' A RDBESDataObject converted from package SDAResources dataset gpa +#' +#' This data set is derived from the data(gpa). The design is 1-stage cluster +#' sampling with clusters of equal sizes. Each cluster (suite) has 4 elements +#' with the same weight. The target variable is gpa. +#' +#' @format A list containing entries required for H1 RDBES data: +#' \describe{ +#' \item{DE}{the Design data table. Contains 1 DE row with +#' DEstratumName == "Pckg_SDAResources_gpa_H1"} +#' \item{SD}{the Sampling Details data table. Contains 1 child SD row} +#' \item{VS}{the Vessel Selection data table. Contains 20 child rows +#' (the 20 observations), each associated to its cluster (suite), +#' VSnumberTotalClusters is 100, VSnumberTotal is 4 because all elements in +#' cluster are sampled} +#' \item{FT}{the Fishing Trip data table. Just 1:1 links to the final data +#' (in SA)} +#' \item{FO}{the Fishing Operation data table. Just 1:1 links to the final +#' data (in SA)} +#' \item{SS}{the Species Selection data table. Just 1:1 links to the final +#' data (in SA)} +#' \item{SA}{the Sample data table. Each gpa score is a +#' SAsampleWeightMeasured. ATT gpa scores are *100 to meet type requirement +#' (integer)} +#' \item{FM}{the Frequency Measure data table} +#' \item{BV}{the Biological Variable data table} +#' \item{VD}{the Vessel Details data table} +#' \item{SL}{the Species List data table} +#' \item{IS}{the Individual Species table} +#' } +#' @source \url{https://CRAN.R-project.org/package=SDAResources} +"Pckg_SDAResources_gpa_H1" + +#' A RDBESDataObject converted from package SDAResources dataset schools +#' +#' This data set is derived from the data(schools). The design is 2-stage cluster +#' sampling with clusters of unequal sizes and Npsu not known. Clusters are +#' schools (schoolid). Clusters (psu) are unequal sized (Mi). In each cluster, +#' 20 students are selected (ssus) and measured (nrows). The total number of +#' psus is known (75). The target variable is mathlevel. +#' +#' @format A list containing entries required for H1 RDBES data: +#' \describe{ +#' \item{DE}{the Design data table. Contains 1 DE row with +#' DEstratumName == "Pckg_SDAResources_schools_H1"} +#' \item{SD}{the Sampling Details data table. Contains 1 child SD row} +#' \item{VS}{the Vessel Selection data table. Contains 200 child rows +#' (the 200 students observed), each associated to its cluster (schoolid), +#' VSnumberTotalClusters is 100, VSnumberTotal is Mi} +#' \item{FT}{the Fishing Trip data table. Just 1:1 links to the final data +#' (in SA)} +#' \item{FO}{the Fishing Operation data table. Just 1:1 links to the +#' final data (in SA)} +#' \item{SS}{the Species Selection data table. Just 1:1 links to the +#' final data (in SA)} +#' \item{SA}{the Sample data table. Each volume is a SAsampleWeightMeasured} +#' \item{FM}{the Frequency Measure data table} +#' \item{BV}{the Biological Variable data table} +#' \item{VD}{the Vessel Details data table} +#' \item{SL}{the Species List data table} +#' \item{IS}{the Individual Species table} +#' } +#' @source \url{https://CRAN.R-project.org/package=SDAResources} +"Pckg_SDAResources_schools_H1" -#-------Other example data---------- - -#' One quarter of sample data from swedish shrimp landings of the -#' SWE_OTB_CRU_32-69_0_0 fishery -#' -#' A dataset of rdbesEstimObj type containing simplified haul-level -#' samples (rows) of shrimp landings (targetValue, in kg) observed onboard using -#' H1 of RDBES with UPWOR on vessels. Data is provided for developing/testing -#' purposes only. -#' -#' @format A data frame with 10 rows and 95 variables: -#' -#' - DEsamplingScheme - Sampling Scheme -#' - DEyear - Year of data collection -#' - DEstratumName - Fishery code -#' - DEhierarchyCorrect - Design Variable of RDBES. More details in RDBES documentation -#' - DEhierarchy - Design Variable of RDBES. More details in RDBES documentation -#' - DEsampled - Design Variable of RDBES. More details in RDBES documentation -#' - DEreasonNotSampled - Design Variable of RDBES. More details in RDBES documentation -#' - SDcountry - Country that collected the data -#' - SDinstitution - Institution that collected the data -#' - su1, su2, su3, su4, su5 - sampling units of RDBES. More details in RDBES documentation -#' - XXXnumberSampled, ... - Design Variables of RDBES. More details in RDBES documentation -#' - targetValue - estimate of weight landed in each haul (in kg) -#' - plus XX other columns -#' -#' @source Nuno Prista @ SLU Aqua, 2022 -"shrimps" - -#' One quarter of sample data from swedish shrimp catches of the -#' SWE_OTB_CRU_32-69_0_0 fishery -#' -#' A dataset of rdbesEstimObj type containing simplified haul-level -#' samples (rows) of shrimp catches (targetValue, in kg) observed onboard using -#' H1 of RDBES with UPWOR on vessels. Catches are divided into three strata (91, 92, 93_94) -#' that correspond to sorting sieves used onboard. Data is provided for developing/testing -#' purposes only. -#' -#' @format A data frame with 10 rows and 95 variables: -#' -#' - DEsamplingScheme - Sampling Scheme -#' - DEyear - Year of data collection -#' - DEstratumName - Fishery code -#' - DEhierarchyCorrect - Design Variable of RDBES. More details in RDBES documentation -#' - DEhierarchy - Design Variable of RDBES. More details in RDBES documentation -#' - DEsampled - Design Variable of RDBES. More details in RDBES documentation -#' - DEreasonNotSampled - Design Variable of RDBES. More details in RDBES documentation -#' - SDcountry - Country that collected the data -#' - SDinstitution - Institution that collected the data -#' - su1, su2, su3, su4, su5 - sampling units of RDBES. More details in RDBES documentation -#' - XXXnumberSampled, ... - Design Variables of RDBES. More details in RDBES documentation -#' - su5stratumName - sieve fraction -#' - targetValue - estimate of weight fraction in each haul (in kg) -#' - plus XX other columns -#' -#' @source Nuno Prista @ SLU Aqua, 2022 -"shrimpsStrat" diff --git a/R/detectNonExportedFunctionsInExamples.R b/R/detectNonExportedFunctionsInExamples.R new file mode 100644 index 00000000..f0d6e174 --- /dev/null +++ b/R/detectNonExportedFunctionsInExamples.R @@ -0,0 +1,377 @@ +#' Detect Non-Exported Functions Used in Package Examples +#' +#' Scans the \file{man/} directory of an R package and identifies calls to +#' non-exported functions in the examples sections of its Rd documentation. +#' Function definitions are collected from the package's \file{R/} directory, +#' and exported function names are read from the package's +#' \file{NAMESPACE} file. +#' +#' The function does not execute examples. It parses the documentation and +#' source files to identify candidate calls to non-exported functions. +#' +#' @param pkgPath Character string specifying the path to the root directory +#' of an R package source tree. The directory should contain \file{man/}, +#' \file{R/}, and \file{NAMESPACE}. +#' +#' @return A data frame with one row per detected call and the following +#' columns: +#' \describe{ +#' \item{topic}{Name of the Rd documentation topic in which the call +#' was detected, usually the filename without the \file{.Rd} extension.} +#' \item{function_name}{Name of the non-exported function detected in +#' the example.} +#' \item{call_type}{Type of call: \code{unqualified} for a direct +#' function call, or \code{explicit :::} for an explicitly +#' namespace-qualified call using the triple-colon operator.} +#' \item{defined_in_package}{Logical value indicating whether the +#' function was found among the function definitions detected in the +#' package's \file{R/} source files.} +#' } +#' +#' If no matching calls are found, an empty data frame with these columns +#' is returned. +#' +#' @details +#' The function identifies two types of calls: +#' \itemize{ +#' \item Unqualified calls to functions defined in the package source +#' that are not listed as exports in \file{NAMESPACE}. +#' \item Calls using \code{pkg:::fun()}, where \code{pkg} matches the +#' package directory name and \code{fun} is not exported. +#' } +#' +#' The \code{defined_in_package} column is based on static inspection of +#' source files. A value of \code{FALSE} for an explicitly qualified call +#' means that a matching direct function definition was not found. This +#' does not necessarily mean that the function is absent; it may be generated +#' dynamically or defined in a form not recognized by the detector. +#' +#' The analysis is static and may not identify calls created dynamically +#' through mechanisms such as \code{get()}, \code{assign()}, or +#' metaprogramming. It also relies on the package's source files and +#' \file{NAMESPACE} being consistent with the documentation being inspected. +#' +#' @seealso [tools::parse_Rd()], [tools::Rd2ex()] +#' +#' @section Development review: +#' - AI-assisted: Yes +#' - Review: +#' - Notes/scope: not really reviewed, just worked when needed and could be useful +#' in the future +#' +#' @keywords internal +#' +#' @examples +#' \dontrun{ +#' # Scan a local package source directory +#' issues <- detectNonExportedFunctionsInExamples("path/to/package") +#' +#' # Display all detected calls +#' print(issues) +#' +#' # Inspect calls whose definitions were not found in the source +#' subset(issues, defined_in_package == FALSE) +#' } +#' + +detectNonExportedFunctionsInExamples <- function(pkgPath) { + stopifnot(dir.exists(pkgPath)) + + man_dir <- file.path(pkgPath, "man") + r_dir <- file.path(pkgPath, "R") + ns_file <- file.path(pkgPath, "NAMESPACE") + + if (!dir.exists(man_dir)) { + stop("Cannot find package man/ directory: ", man_dir) + } + + # -------------------------------------------------- + # 1. Read exported function names from NAMESPACE + # -------------------------------------------------- + exports <- character() + + if (file.exists(ns_file)) { + ns_lines <- readLines(ns_file, warn = FALSE) + + export_lines <- grep( + "^\\s*export\\s*\\(", + ns_lines, + value = TRUE + ) + + exports <- unlist( + lapply(export_lines, function(line) { + matches <- regmatches( + line, + gregexpr( + 'export\\s*\\(\\s*["\u0060]?[^)"\u0060]+\\)', + line, + perl = TRUE + ) + ) + matches + }) + ) + + # Parse NAMESPACE directives properly where possible + ns_exprs <- tryCatch( + parse(ns_file), + error = function(e) expression() + ) + + exports <- unique(unlist(lapply(ns_exprs, function(expr) { + if (is.call(expr) && + identical(expr[[1L]], as.name("export"))) { + as.character(expr[-1L]) + } else { + character() + } + }))) + } + + # -------------------------------------------------- + # 2. Find functions defined in the package's R files + # -------------------------------------------------- + internal_functions <- character() + + if (dir.exists(r_dir)) { + r_files <- list.files( + r_dir, + pattern = "\\.[Rr]$", + full.names = TRUE, + recursive = TRUE + ) + + for (file in r_files) { + exprs <- tryCatch( + parse(file), + error = function(e) expression() + ) + + find_definitions <- function(x) { + out <- character() + + if ( + is.call(x) && + length(x) >= 3L && + ( + identical(x[[1L]], as.name("<-")) || + identical(x[[1L]], as.name("=")) || + identical(x[[1L]], as.name("<<-")) + ) && + is.symbol(x[[2L]]) && + is.call(x[[3L]]) && + identical(x[[3L]][[1L]], as.name("function")) + ) { + out <- c(out, as.character(x[[2L]])) + } + + if (is.call(x) || is.expression(x) || is.pairlist(x)) { + for (i in seq_along(x)) { + # Skip missing arguments + if (identical(x[[i]], quote(expr = ))) { + next + } + + out <- c(out, find_definitions(x[[i]])) + } + } + + unique(out) + } + + internal_functions <- c( + internal_functions, + unlist(lapply(exprs, find_definitions)) + ) + } + } + + internal_functions <- unique(internal_functions) + + # -------------------------------------------------- + # 3. Extract calls from the original \examples{} tags + # -------------------------------------------------- + rd_files <- list.files( + man_dir, + pattern = "\\.Rd$", + full.names = TRUE, + recursive = TRUE + ) + + results <- list() + + get_calls <- function(x) { + calls <- character() + + if (is.call(x)) { + head <- x[[1L]] + + # Ordinary function call: foo(...) + if (is.symbol(head)) { + calls <- c(calls, as.character(head)) + } + + # Namespace-qualified call: pkg::foo(...) or pkg:::foo(...) + if ( + is.call(head) && + length(head) == 3L && + ( + identical(head[[1L]], as.name("::")) || + identical(head[[1L]], as.name(":::")) + ) && + is.symbol(head[[2L]]) && + is.symbol(head[[3L]]) + ) { + operator <- as.character(head[[1L]]) + + calls <- c( + calls, + paste0( + as.character(head[[2L]]), + operator, + as.character(head[[3L]]) + ) + ) + } + + # Traverse arguments, skipping missing arguments + for (i in seq_along(x)[-1L]) { + arg <- tryCatch(x[[i]], error = function(e) NULL) + + if (!is.null(arg)) { + calls <- c(calls, get_calls(arg)) + } + } + + } else if (is.expression(x) || is.pairlist(x) || is.list(x)) { + for (i in seq_along(x)) { + el <- tryCatch(x[[i]], error = function(e) NULL) + + if (!is.null(el)) { + calls <- c(calls, get_calls(el)) + } + } + } + + unique(calls) + } + + # Recursively extract text under \examples{} + extract_examples <- function(rd) { + found <- list() + + walk <- function(node) { + if (!is.list(node)) return() + + if (identical(attr(node, "Rd_tag"), "\\examples")) { + found[[length(found) + 1L]] <<- node + return() + } + + for (child in node) { + walk(child) + } + } + + walk(rd) + found + } + + for (file in rd_files) { + rd <- tryCatch( + tools::parse_Rd(file), + error = function(e) NULL + ) + + if (is.null(rd)) next + + examples <- extract_examples(rd) + if (!length(examples)) next + + topic <- sub("\\.Rd$", "", basename(file)) + + for (example in examples) { + # Convert Rd markup to example R code. This does not + # execute the examples. + code <- paste( + unlist(lapply(example, function(part) { + paste(as.character(part), collapse = "") + })), + collapse = "\n" + ) + + # Fallback to Rd2ex if direct extraction cannot be parsed + exprs <- tryCatch( + parse(text = code), + error = function(e) NULL + ) + + if (is.null(exprs)) { + tmp <- tempfile(fileext = ".R") + tryCatch({ + tools::Rd2ex(rd, out = tmp) + exprs <- parse(file = tmp) + }, error = function(e) { + exprs <<- NULL + }, finally = { + unlink(tmp) + }) + } + + if (is.null(exprs)) next + + calls <- unique(unlist(lapply(exprs, get_calls))) + + for (call_name in calls) { + # Namespace-qualified calls + if (grepl("::", call_name, fixed = TRUE)) { + parts <- strsplit(call_name, "::", fixed = TRUE)[[1L]] + fn <- parts[length(parts)] + operator <- if (grepl(":::", call_name, fixed = TRUE)) { + ":::" + } else { + "::" + } + + if (operator == ":::" && + parts[1L] == basename(pkgPath) && + !fn %in% exports) { + results[[length(results) + 1L]] <- data.frame( + topic = topic, + function_name = fn, + call_type = "explicit :::", + defined_in_package = fn %in% internal_functions, + stringsAsFactors = FALSE + ) + } + + next + } + + # Unqualified calls to package-defined functions + if (call_name %in% internal_functions && + !call_name %in% exports) { + results[[length(results) + 1L]] <- data.frame( + topic = topic, + function_name = call_name, + call_type = "unqualified", + defined_in_package = TRUE, + stringsAsFactors = FALSE + ) + } + } + } + } + + if (!length(results)) { + return(data.frame( + topic = character(), + function_name = character(), + call_type = character(), + defined_in_package = logical() + )) + } + + unique(do.call(rbind, results)) +} diff --git a/R/doDBEestimantionObjUpp.R b/R/doDBEestimantionObjUpp.R index 554ea72d..109e2404 100644 --- a/R/doDBEestimantionObjUpp.R +++ b/R/doDBEestimantionObjUpp.R @@ -8,9 +8,8 @@ #' #' @examples #' \dontrun{ -#' H1 <- -#' readRDS("./WKRDB-EST2/testData/output/DBErawObj/DBErawObj_DK_1966_H1.rds") -#' H1out <- doDBEestimantionObjUpp(H1) +#' myH1DataObject <- H1Example +#' H1out <- RDBEScore:::doDBEestimantionObjUpp(myH1DataObject) #' } diff --git a/R/doDBestimation.R b/R/doDBestimation.R index e6ac66cd..690c6ac2 100644 --- a/R/doDBestimation.R +++ b/R/doDBestimation.R @@ -22,7 +22,7 @@ #' @examples #' \dontrun{ #' data(shrimps) -#' doDBestimation (x = shrimps, estimateType = "total", +#' RDBEScore:::doDBestimation (x = shrimps, estimateType = "total", #' pointEstimator = "Unbiased", varEstimator = "WRonPSUviaPsi",stage = 0, #' domainOfinterest = NULL ) #' } diff --git a/R/doEstimationForAllStrata.R b/R/doEstimationForAllStrata.R index 1cc650fc..94340377 100644 --- a/R/doEstimationForAllStrata.R +++ b/R/doEstimationForAllStrata.R @@ -12,17 +12,17 @@ #' @examples #' \dontrun{ #' -#' myH1RawObject <- -#' importRDBESDataCSV(rdbesExtractPath = "tests\\testthat\\h1_v_1_19") +#' data("H1Example") +#' myH1DataObject <- H1Example #' #' # Update our test data with some random sample measurements -#' myH1RawObject[["SA"]]$SAsampWtLive <- -#' round(runif(n = nrow(myH1RawObject[["SA"]]), min = 1, max = 100)) +#' myH1DataObject[["SA"]]$SAsampWtLive <- +#' round(runif(n = nrow(myH1DataObject[["SA"]]), min = 1, max = 100)) #' -#' myH1EstObj <- createRDBESEstObject(myH1RawObject, 1) +#' myH1EstObj <- createRDBESEstObject(myH1DataObject, 1) #' #' myStrataEst <- doEstimationForAllStrata( -#' RDBESDataObjectForEstim = myH1EstObj, +#' RDBESEstObjectForEstim = myH1EstObj, #' targetValue = 'SAsampWtLive' #' ) #' } diff --git a/R/doEstimationRatio.R b/R/doEstimationRatio.R index 73cf5c79..8083ed2b 100644 --- a/R/doEstimationRatio.R +++ b/R/doEstimationRatio.R @@ -1,346 +1,511 @@ #' Estimate Numbers and Mean Values by Length or Age Class #' -#' The function is under development and does not work yet. +#' @param RDBESDataObj A validated RDBESDataObject containing hierarchical +#' sampling and biological data. Must include relevant tables (SA, FM, +#' and/or BV) depending on the lower hierarchy. +#' @param targetValue A character string specifying the type of composition to +#' estimate. Options are \code{"LengthComp"} or \code{"AgeComp"}. +#' @param raiseVar The raising variable used to construct the ratio estimator. +#' Options are \code{"Weight"} (SAtotalWtMes / SAsampWtMes), +#' \code{"Count"} (SAnumTotal / SAnumSamp), or any other value which will +#' use \code{SAauxVarValue} directly as the raise factor. +#' @param classUnits Units of the length class intervals, e.g. \code{"mm"} or +#' \code{"cm"}. Used only for \code{targetValue = "LengthComp"}: in LH A +#' and B, checks consistency with FM data; in LH C, used to transform raw BV +#' lengths before class assignment. +#' Codes: \url{https://vocab.ices.dk/?ref=1608} +#' @param classBreaks A numeric vector of three values: +#' \code{c(min, max, width)}. Defines the length class intervals. Used only +#' for \code{targetValue = "LengthComp"}. +#' @param LWparam A numeric vector of length two \code{c(a, b)} specifying the +#' weight-length relationship (W = a * L^b). Used in LH A and B when +#' individual weights are absent from BV but lengths are available. +#' @param verbose Logical; if \code{TRUE}, informational messages are printed +#' during processing. #' -#' @param RDBESDataObj A validated RDBESDataObject containing hierarchical sampling and biological data. Must include appropriate tables (e.g., CL, CE, SA, FM, or BV) depending on estimation requirements. -#' @param targetValue A character string specifying the type of composition to estimate. Options are "LengthComp" or "AgeComp". -#' @param raiseVar The variable used to construct the ratio. -#' @param classUnits Units of the class intervals for length or age, typically "mm" for millimeters or "cm" for centimeters. Used in defining class intervals. -#' @param classBreaks A numeric vector of three values: minimum value, maximum value, and class width (e.g., c(100, 300, 10)). Defines the class intervals for grouping lengths or ages. -#' @param LWparam A numeric vector of length two specifying parameters (a, b) for the weight-length relationship (W = a * L^b). Used if no direct weights are available but lengths are provided. -#' @param lowerAux A numeric or character vector referencing a variable in the SA table used as an auxiliary variable for ratio estimation (e.g., sample weights, sub-sample expansion factors). -#' @param verbose Logical; if TRUE, detailed messages are printed during processing. +#' @return A \code{data.table} with estimated numbers at length or age and +#' associated mean values. Key output columns: +#' \itemize{ +#' \item \code{LengthClass} or \code{Age} — the grouping variable +#' \item \code{NumbersAtLength} or \code{NumbersAtAge} — raised estimates +#' \item \code{MeanWeightAtLength} or \code{BVMeanWeight} — mean weight +#' \item \code{MeanLengthAtAge} — mean length at age (AgeComp only) +#' \item \code{raiseFactor} — the SA-level raise factor applied +#' } +#' +#' @details +#' The three lower hierarchies differ in which tables are present: +#' \itemize{ +#' \item \strong{LH A}: \code{SA -> FM -> BV}. FM holds the length-frequency; +#' BV holds individual biological measurements for a subsample of +#' fish within each FM length class. Supports both LengthComp and AgeComp. +#' \item \strong{LH B}: \code{SA -> FM} only. FM holds the length-frequency; +#' no individual biological measurements (no BV). Supports +#' LengthComp only; AgeComp is not possible without BV. +#' \item \strong{LH C}: \code{SA -> BV} only. Individual biological +#' measurements link directly to SA; no FM length-frequency tally. +#' Supports both LengthComp and AgeComp. +#' } #' -#' @return A list or data.table containing the estimated numbers at length or age and associated mean values such as weight and length, depending on input and target type. -# InterCatch age composition data -# Numbers at age -# Mean weight at age -# Mean length at age -# Intercatch length composition data -# Numbers at legth -# Mean weight at length -## Measure indv weight of fish -## LW relationship: a, b parameters -# For now assume we have all the data we need -# Counts, indv weights, lengths (mm) and ages -# TODO check differences if length classes are defined later -# Unit conversion later step : for LC -# TODO add check for unique sampling scheme -# TODO add an argument to toggle stratification in estimation on/off -# TODO need to implement the BV conversion from typeMeas to typeAssess -# TODO add info about the strata (species, area, season, metier/gear/fleet) #' @importFrom utils tail +#' @export doEstimationRatio <- function(RDBESDataObj, - targetValue = "LengthComp", - raiseVar = "Weight", - classUnits = "mm", - classBreaks = c(100, 300, 10), # cut - LWparam = NULL, # vector of two values - lowerAux = NULL, # you can use a strongly correlated value present in your data for the estimation of the values of interest - verbose = FALSE){ - - raiseVar <- "Weight" - RDBESDataObj <- H8ExampleEE1 - # Check we have a valid RDBESEstObject before doing anything else + targetValue = "LengthComp", + raiseVar = "Weight", + classUnits = "mm", + classBreaks = c(100, 300, 10), + LWparam = NULL, + verbose = FALSE) { + + + #TODO stratification SA, BV + #TODO add here the upper h? + #TODO build tests + #TODO mean weight at age and length, Check. + #TODO check the hierachies are checked properly + #TODO throw error when the raiseVar is NA + #TODO account for subsample weight when appropriate (e.g., BV raise factor and the SA raise factor) + + # --------------------------------------------------------------------------- + # Checks + # --------------------------------------------------------------------------- + RDBEScore::validateRDBESDataObject(RDBESDataObj, verbose = FALSE) - # RDBESDataObj <- createRDBESDataObject(input = c("./NLdata/2025_10_14_093927.zip", - # "./NLdata/HCL_2025_10_06_102840215.zip")) - # validateRDBESDataObject(h1, verbose = TRUE) + if (length(unique(RDBESDataObj$DE$DEhierarchy)) > 1) + stop("Multiple upper hierarchies not implemented") - # Check upper hierarchy - DEhierarchy <- unique(RDBESDataObj$DE$DEhierarchy) - if(length(unique(DEhierarchy )) > 1){ - stop("Multiple upper hierarchies not yet implemented")} - # Check lower hierarchy - if(length(unique(RDBESDataObj$SA$SAlowHierarchy)) > 1){ + if (length(unique(RDBESDataObj$SA$SAlowHierarchy)) > 1) stop("Multiple lower hierarchies not allowed") + + RDBESEstRatioObj <- Filter(Negate(is.null), RDBESDataObj) + + lh <- unique(RDBESEstRatioObj$SA$SAlowHierarchy) + + # Warn if length-class arguments are passed but irrelevant + if (targetValue == "AgeComp") { + if (!missing(classUnits)) + warning("'classUnits' is ignored when targetValue = 'AgeComp'.") + if (!missing(classBreaks)) + warning("'classBreaks' is ignored when targetValue = 'AgeComp'.") } - RDBESEstRatioObj <- RDBESDataObj[c("CL", "CE", RDBEScore::getTablesInRDBESHierarchy(DEhierarchy))] - - # Filter out NULL tables - RDBESEstRatioObj <- Filter(Negate(is.null), RDBESEstRatioObj) - -#---------------------- - if(raiseVar == "Weight"){ - if(unique(RDBESDataObj$SA$SAlowHierarchy) == "B" ){ - stop("Lower hierarchy B not yet implemented for weight") - }else{ - weightVar <- grep("(?i)weight", unique(RDBESDataObj$BV$BVtypeMeas), value = TRUE) - # weightVar <- c("WeightLive", "WeightGutted", "WeightMeasured") - if (interactive()) { - if(length(unique(weightVar)) > 1) { - # Print a numbered menu and get user's selection - idx <- utils::menu(weightVar, title = "Select the BV weight type to use:") - if (idx == 0L) stop("Selection cancelled.") - wcol <- weightVar[idx] - weightName <- paste0("BV", wcol) - } else { + # AgeComp is not possible without individual fish records + if (targetValue == "AgeComp" && lh == "B") + stop("AgeComp is not possible with lower hierarchy B: LH B has no individual ", + "fish records (no BV table). Use LH A or LH C for age composition.") + + # --------------------------------------------------------------------------- + # Get the appropriate weight for raising + # --------------------------------------------------------------------------- + + wcol <- NULL + + bv_present <- !is.null(RDBESEstRatioObj$BV) + + if (bv_present) { + + weightVar <- grep("(?i)weight", unique(RDBESEstRatioObj$BV$BVtypeMeas), + value = TRUE, perl = TRUE) + + if (lh == "A" && (length(weightVar) == 0 || all(is.na(weightVar)))) + stop("No individual weight measured in BV (required for lower hierarchy A)") + + if (length(weightVar) > 0) { + if (interactive() && length(unique(weightVar)) > 1) { + idx <- utils::menu(weightVar, title = "Select the BV weight type to use:") + if (idx == 0L) stop("Selection cancelled.") + wcol <- weightVar[idx] + } else { + if (length(unique(weightVar)) > 1) + message("Multiple weight types found; using first: ", weightVar[1L]) + else if (verbose) message("Only one weight type present. Using: ", weightVar[1L]) - wcol <- weightVar[1L] - weightName <- paste0("BV", wcol) - } + wcol <- weightVar[1L] } } } -# Do we need both CL and CE? Allow the user to define the population (i.e. effort or landings or both)? + # --------------------------------------------------------------------------- + # Helpers - SHould be moved to utils? + # --------------------------------------------------------------------------- + + # Check FM length-class consistency (LH A and B) + checkLC <- function(fm, classUnits, classBreaks) { + vocabUnits <- c("mm", "25mm", "cm", "5cm", "scm", "smm") + fmUnits <- unique(fm$FMaccuracy) + + if (!classUnits %in% vocabUnits) + stop(paste("Invalid classUnits:", classUnits, + "\nMust be one of:", paste(vocabUnits, collapse = ", "))) + if (length(fmUnits) > 1) + stop("Multiple class units found in FM data: ", paste(fmUnits, collapse = ", ")) + if (!classUnits %in% fmUnits) + stop(paste("Mismatch: user classUnits (", classUnits, + ") vs FM data units (", paste(fmUnits, collapse = ", "), ").")) + + fmBreaks <- range(fm$FMclassMeas, na.rm = TRUE) + userRange <- range(seq(classBreaks[1], classBreaks[2], classBreaks[3])) + if (any(userRange != fmBreaks)) + stop("classBreaks (", paste(userRange, collapse = "-"), + ") differ from FM data range (", paste(fmBreaks, collapse = "-"), ").") + + message("Length class checks passed: units and breaks are consistent.") + } - # Not working check + brks <- seq(classBreaks[1], classBreaks[2], by = classBreaks[3]) - # if(!names(RDBESDataObj) %in% c("CL", "CE")){ - # stop("The object does not have population data") - # } + assignLengthClass <- function(lengths) { + cut(lengths, + breaks = brks, + right = FALSE, + include.lowest = TRUE, + labels = head(brks, -1)) + } -# Check which tables exist after SA + # Unit conversion for individual BV lengths (LH C) - Should ICES vocab used directly here? + convertLength <- function(x, fromUnit, toUnit) { + toMM <- switch(fromUnit, + "mm" = 1, "cm" = 10, "25mm" = 25, "5cm" = 50, + stop("Unknown fromUnit: ", fromUnit)) + fromMM <- switch(toUnit, + "mm" = 1, "cm" = 10, "25mm" = 25, "5cm" = 50, + stop("Unknown toUnit: ", toUnit)) + x * toMM / fromMM + } -# Does anything exist after SA? + # Derive individual BV weights from wcol or LW relationship + addBVweight <- function(bv_wide, lengthVar = NULL) { + if (!is.null(wcol) && wcol %in% names(bv_wide)) { + bv_wide[, BVweight := as.numeric(bv_wide[[wcol]])] + } else if (!is.null(LWparam) && !is.null(lengthVar) && lengthVar %in% names(bv_wide)) { + bv_wide[, BVweight := LWparam[1] * as.numeric(bv_wide[[lengthVar]]) ^ LWparam[2]] + } else { + bv_wide[, BVweight := NA_real_] + } + bv_wide + } - if(length(unique(names(RDBESEstRatioObj))) > 1){ - if(!tail(names(RDBESEstRatioObj), n = 1) %in% c("FM", "BV")){ - stop("No FM or BV tables provided") - } - } + # Apply SA-level raise factor + applySARaise <- function(su, numbersInCol, numbersOutCol) { + if (raiseVar == "Weight") { + su[, raiseFactor := SAtotalWtMes / SAsampWtMes] + } else if (raiseVar == "Count") { + su[, raiseFactor := SAnumTotal / SAnumSamp] + } else { + su[, raiseFactor := as.numeric(SAauxVarValue)] + } + su[, (numbersOutCol) := get(numbersInCol) * raiseFactor] + su + } -# Length composition ------------------------------------------------------ - if(targetValue == "LengthComp"){ + # SA columns used across branches + saCols <- c("SAid", "SAlowHierarchy", "SAtotalWtMes", "SAsampWtMes", + "SAnumTotal", "SAnumSamp", "SAauxVarValue", "SAauxVarUnit") -# LH A & B ---------------------------------------------------------------- - if(unique(RDBESEstRatioObj$SA$SAlowHierarchy) %in% c("A", "B")){ + # =========================================================================== + # LENGTH COMPOSITION + # =========================================================================== - # bv <- setDT(RDBESEstRatioObj$BV) - # fm <- setDT(RDBESEstRatioObj$FM) - # bv <- bv[, unique(.SD), .SDcols = c( "FMid","BVfishId", "BVtypeMeas", "BVvalueMeas")] - # bv <- dcast(bv, ... ~ BVtypeMeas , value.var = c("BVvalueMeas"), drop = TRUE) - # bv[, `:=`(LengthTotal = as.numeric(LengthTotal), WeightMeasured = as.numeric(WeightMeasured))] + if (targetValue == "LengthComp") { - # Select only FM data for now - BV possibly used for ALK - warning("Only FM table used. BV is not yet implemented") + # ------------------------------------------------------------------------- + # LH A: SA -> FM -> BV + # FM holds the length-frequency. BV (if present) provides individual + # weights for MeanWeightAtLength; otherwise LWparam is used. + # ------------------------------------------------------------------------- + if (lh == "A") { + warning("Lower hierarchy A: only the FM table is used to calculate numbers at length.") + fm <- data.table::setDT(RDBESEstRatioObj$FM) + sa <- data.table::setDT(RDBESEstRatioObj$SA) + checkLC(fm = fm, classUnits = classUnits, classBreaks = classBreaks) + fm <- fm[, unique(.SD), .SDcols = c("SAid", "FMid", "FMclassMeas", + "FMnumAtUnit", "FMaccuracy", "FMtypeAssess")] + sa <- sa[, unique(.SD), .SDcols = saCols] + sa[, SAauxVarValue := as.numeric(SAauxVarValue)] + fm[, LengthClass := assignLengthClass(FMclassMeas)] + fm1 <- fm[ + , .(FMNumbersAtLength = sum(FMnumAtUnit, na.rm = TRUE)), + by = .(SAid, LengthClass) + ][, FMTotCount := sum(FMNumbersAtLength, na.rm = TRUE), by = SAid] + + su <- merge(fm1, sa, by = "SAid") + su <- applySARaise(su, + numbersInCol = "FMNumbersAtLength", + numbersOutCol = "NumbersAtLength") + + # Mean weight at length: from BV individual weights or LW relationship + if (bv_present && !is.null(wcol)) { + bv <- data.table::setDT(RDBESEstRatioObj$BV) + bv_w <- bv[BVtypeMeas == wcol, + .(FMid, BVweight = as.numeric(BVvalueMeas))] + bv_lc <- merge(bv_w, fm[, .(FMid, SAid, LengthClass)], by = "FMid") + mean_w <- bv_lc[, .(MeanWeightAtLength = mean(BVweight, na.rm = TRUE)), + by = .(SAid, LengthClass)] + su <- merge(su, mean_w, by = c("SAid", "LengthClass"), all.x = TRUE) + } else if (!is.null(LWparam)) { + fm_lw <- fm[, .(LengthClass, FMclassMeas)][, .SD[1], by = LengthClass] + fm_lw[, MeanWeightAtLength := LWparam[1] * FMclassMeas ^ LWparam[2]] + su <- merge(su, fm_lw[, .(LengthClass, MeanWeightAtLength)], + by = "LengthClass", all.x = TRUE) + } else { + if (verbose) + message("No BV weights or LWparam supplied: MeanWeightAtLength set to NA.") + su[, MeanWeightAtLength := NA_real_] + } - if(!is.null(LWparam)){ + return(su) + } + + # ------------------------------------------------------------------------- + # LH B: SA -> FM only + # FM holds the length-frequency; no BV table exists. + # MeanWeightAtLength can only be derived from LWparam. + # ------------------------------------------------------------------------- + + if (lh == "B") { + + fm <- data.table::setDT(RDBESEstRatioObj$FM) + sa <- data.table::setDT(RDBESEstRatioObj$SA) - stop("Not yet implemented") + checkLC(fm = fm, classUnits = classUnits, classBreaks = classBreaks) + fm <- fm[, unique(.SD), .SDcols = c("SAid", "FMid", "FMclassMeas", + "FMnumAtUnit", "FMaccuracy", "FMtypeAssess")] + sa <- sa[, unique(.SD), .SDcols = saCols] + sa[, SAauxVarValue := as.numeric(SAauxVarValue)] - }else{ - # else stop - stop("Nor an auxiliary variable nor lw params are provided. Not possible to produce the mean weight at length") + fm[, LengthClass := assignLengthClass(FMclassMeas)] + + fm1 <- fm[ + , .(FMNumbersAtLength = sum(FMnumAtUnit, na.rm = TRUE)), + by = .(SAid, LengthClass) + ][, FMTotCount := sum(FMNumbersAtLength, na.rm = TRUE), by = SAid] + + su <- merge(fm1, sa, by = "SAid") + su <- applySARaise(su, + numbersInCol = "FMNumbersAtLength", + numbersOutCol = "NumbersAtLength") + + # Mean weight at length: LWparam only (no BV in LH B) + if (!is.null(LWparam)) { + fm_lw <- fm[, .(LengthClass, FMclassMeas)][, .SD[1], by = LengthClass] + fm_lw[, MeanWeightAtLength := LWparam[1] * FMclassMeas ^ LWparam[2]] + su <- merge(su, fm_lw[, .(LengthClass, MeanWeightAtLength)], + by = "LengthClass", all.x = TRUE) + } else { + if (verbose) + message("No LWparam supplied: MeanWeightAtLength set to NA.") + su[, MeanWeightAtLength := NA_real_] } - # otherwise check if you can calculate it - # otherwise stop + return(su) + } + # ------------------------------------------------------------------------- + # LH C: SA -> BV only + # No FM table. Individual fish measurements link directly to SA. + # ------------------------------------------------------------------------- + if (lh == "C") { + if (!bv_present) + stop("Lower hierarchy C requires a BV table.") + bv <- data.table::setDT(RDBESEstRatioObj$BV) + sa <- data.table::setDT(RDBESEstRatioObj$SA) + sa <- sa[, unique(.SD), .SDcols = saCols] + sa[, SAauxVarValue := as.numeric(SAauxVarValue)] + lengthVar <- grep("(?i)length", unique(bv$BVtypeMeas), value = TRUE, perl = TRUE) + if (length(unique(lengthVar)) > 1) + stop("Multiple length types in BV; filter to one before calling.") -# LH C -------------------------------------------------------------------- - }else if(unique(RDBESEstRatioObj$SA$SAlowHierarchy) == "C"){ + bv <- bv[, unique(.SD), .SDcols = c("SAid", "BVfishId", "BVtypeMeas", + "BVvalueMeas", "BVtypeAssess")] + measTypes <- if (!is.null(wcol)) c(lengthVar, wcol) else lengthVar + bv_wide <- bv[BVtypeMeas %in% measTypes, + data.table::dcast(.SD, + SAid + BVfishId ~ BVtypeMeas, + value.var = "BVvalueMeas", drop = TRUE)] - bv <- setDT(RDBESEstRatioObj$BV) - bv <- bv[, unique(.SD), .SDcols = c("SAid", "BVfishId", "BVtypeMeas", "BVvalueMeas")] - bv <- dcast(bv, ... ~ BVtypeMeas , value.var = c("BVvalueMeas"), drop = TRUE) - bv[, (weightName) := as.numeric(get(wcol))] - # TODO this probably needs to be an argument - # or needs to be defined later on? - bv$LengthClass <- floor(bv$LengthTotal/10) # TODO This needs to be defined by the user + bv_wide[, convertedLength := as.numeric(bv_wide[[lengthVar]])] + bv_wide[, LengthClass := assignLengthClass(convertedLength)] + bv_wide <- addBVweight(bv_wide, lengthVar) - bv1 <- bv[ - , .(BVMeanWeight = mean(get(wcol), na.rm = TRUE), - BVNumbersAtLength = .N), + bv1 <- bv_wide[ + , .(BVNumbersAtLength = .N, + MeanWeightAtLength = mean(BVweight, na.rm = TRUE)), by = .(SAid, LengthClass) ][ - # add total count per SAid , BVTotCount := sum(BVNumbersAtLength), by = SAid ][ - # add total weight per SAid - bv[, .(BVTotWeight = sum(get(wcol), na.rm = TRUE)), by = SAid], + bv_wide[, .(BVTotWeight = sum(BVweight, na.rm = TRUE)), by = SAid], on = "SAid" ] - # bv1$BVLengthClassProp <- bv1$BVNumbersAtLength/bv1$TotCount - - - sa <- setDT(RDBESEstRatioObj$SA) - sa <- sa[, unique(.SD), .SDcols = c("SAid", "SAlowHierarchy", "SAtotalWtMes" , "SAsampWtMes", "SAnumTotal", "SAnumSamp", "SAauxVarValue", "SAauxVarUnit" )] # Do not need the - # species, the filtering of the "strata" variables will be done before the estimation - # To test - sa[, SAauxVarValue := as.numeric(SAauxVarValue )] - sa$SAauxVarValue <- 10 - - # TODO add check for subsampling - - su <- merge(bv1, sa, by = c("SAid")) + su <- merge(bv1, sa, by = "SAid") + su <- applySARaise(su, + numbersInCol = "BVNumbersAtLength", + numbersOutCol = "NumbersAtLength") - if(raiseVar == "Weight"){ + return(su) + } + } - su$raiseFactor <- su$SAtotalWtMes/su$SAsampWtMes - su$NumbersAtLength <- su$raiseFactor*su$BVNumbersAtLength - }else if(raiseVar == "Count"){ + # =========================================================================== + # AGE COMPOSITION + # =========================================================================== - su$raiseFactor <- su$SAnumTotal/su$SAnumSamp - su$NumbersAtLength <- su$raiseFactor*su$BVNumbersAtLength + if (targetValue == "AgeComp") { - }else{ + # LH B is caught earlier with a clear error message. - su$NumbersAtLength <- su$SAauxVarValue*su$BVNumbersAtLength + # ------------------------------------------------------------------------- + # LH A: SA -> FM -> BV + # FM length-frequency; BV individual ages stratified under FM + # length classes. Ages are first raised within each FM length class + # (BV subsample -> FM count), then the SA-level raise is applied. + # ------------------------------------------------------------------------- - } + if (lh == "A") { - return(su) + if (!bv_present) + stop("Lower hierarchy A age composition requires a BV table.") + if (is.null(wcol)) + stop("A weight column in BV is required for age composition in lower hierarchy A.") + bv <- data.table::setDT(RDBESEstRatioObj$BV) + fm <- data.table::setDT(RDBESEstRatioObj$FM) + sa <- data.table::setDT(RDBESEstRatioObj$SA) + bv <- bv[, unique(.SD), .SDcols = c("FMid", "BVfishId", "BVtypeMeas", "BVvalueMeas")] + bv <- data.table::dcast(bv, ... ~ BVtypeMeas, value.var = "BVvalueMeas", drop = TRUE) + bv[, BVweight := as.numeric(bv[[wcol]])] - # su$SANumbersAtLength <- su$BVNumbersAtLength * su$SAauxVarValue + if (!"Age" %in% names(bv)) + stop("No 'Age' measurement found in BV. Check BVtypeMeas values.") - # From here onwards need the column names + fm <- fm[, unique(.SD), .SDcols = c("SAid", "FMid", "FMclassMeas", "FMnumAtUnit")] + sa <- sa[, unique(.SD), .SDcols = saCols] + sa[, SAauxVarValue := as.numeric(SAauxVarValue)] - # s <- RDBEScore::getTablesInRDBESHierarchy(DEhierarchy) - # keywords <- c("SA|FM|BV") - # hierarchyTabs <-s[!is.na(gsub(keywords, NA, s))] - # # Get the table before the SA (most likely SS) - # nextTab <- tail(hierarchyTabs, n = 1) - # # Get table SA - 2 - # nextTab1 <- tail(hierarchyTabs, n = ) - # - # - # upperHier1 <- setDT(RDBESEstRatioObj[[nextTab]]) - # cnames1 <- paste0(nextTab, "year") - # upperHier1 <- upperHier1[, unique(.SD), .SDcols = c("SAid", "SAspeCode","SAlowHierarchy", "SAauxVarValue")] + fm_tot <- fm[, .(FMnumAtUnit = sum(FMnumAtUnit, na.rm = TRUE), + SAid = SAid[1]), + by = FMid] + bv1 <- bv[ + , .(BVMeanWeight = mean(BVweight, na.rm = TRUE), + BVNumbersAtAge = .N), + by = .(FMid, Age) + ][, BVTotCount := sum(BVNumbersAtAge), by = FMid] + + # Raise within FM length class: BV subsample -> FM tally + bv2 <- merge(bv1, fm_tot, by = "FMid") + bv2[, num_raise := fifelse(BVTotCount > 0, FMnumAtUnit / BVTotCount, NA_real_)] + bv2[, N_at_age_FM := BVNumbersAtAge * num_raise] + + # Mean length at age + lengthVar <- grep("(?i)length", names(bv), value = TRUE, perl = TRUE) + if (length(lengthVar) > 0) { + lv1 <- lengthVar[1] + mean_len <- bv[, .(MeanLengthAtAge = mean(as.numeric(bv[[lv1]]), + na.rm = TRUE)), + by = .(FMid, Age)] + bv2 <- merge(bv2, mean_len, by = c("FMid", "Age"), all.x = TRUE) + } else { + bv2[, MeanLengthAtAge := NA_real_] + } + # Aggregate from FM level to SA level + bv3 <- bv2[ + , .(N_at_age_SA = sum(N_at_age_FM, na.rm = TRUE), + BVMeanWeight = weighted.mean(BVMeanWeight, BVNumbersAtAge, na.rm = TRUE), + MeanLengthAtAge = weighted.mean(MeanLengthAtAge, BVNumbersAtAge, na.rm = TRUE)), + by = .(SAid, Age) + ] - # if both lengths and weight exist - # if(isTRUE(any(grepl("Length", RDBESEstRatioObj$BV$BVtypeAssess)) & any(grepl("Weight", RDBESEstRatioObj$BV$BVtypeAssess)))){ - # - # su$Wratio <- su$SAtotalWtMes/su$SAsampWtMes - # su$SANumbersAtLength <- su$BVNumbersAtLength * su$Wratio - # - # }else{ - # stop("Not yet implemented") - # } + su <- merge(bv3, sa, by = "SAid") + su <- applySARaise(su, + numbersInCol = "N_at_age_SA", + numbersOutCol = "NumbersAtAge") + return(su) } + # ------------------------------------------------------------------------- + # LH C: SA -> BV only + # No FM table. Individual fish measurements link directly to SA. + # ------------------------------------------------------------------------- + if (lh == "C") { -# Age composition --------------------------------------------------------- - }else if(targetValue == "AgeComp"){ - - - -# LH C -------------------------------------------------------------------- - + bv <- data.table::setDT(RDBESEstRatioObj$BV) + sa <- data.table::setDT(RDBESEstRatioObj$SA) + sa <- sa[, unique(.SD), .SDcols = saCols] + sa[, SAauxVarValue := as.numeric(SAauxVarValue)] - if(unique(RDBESDataObj$SA$SAlowHierarchy) == "C"){ - - bv <- setDT(RDBESEstRatioObj$BV) bv <- bv[, unique(.SD), .SDcols = c("SAid", "BVfishId", "BVtypeMeas", "BVvalueMeas")] - bv <- dcast(bv, ... ~ BVtypeMeas , value.var = c("BVvalueMeas"), drop = TRUE) - bv[, `:=`( WeightMeasured = as.numeric(get(wcol)))] - # TODO this probably needs to be an argument - # or needs to be defined later on? + bv <- data.table::dcast(bv, ... ~ BVtypeMeas, value.var = "BVvalueMeas", drop = TRUE) + + if (!"Age" %in% names(bv)) + stop("No 'Age' measurement found in BV. Check BVtypeMeas values.") + + # Resolve weight outside data.table to avoid get() scoping issues in j + if (!is.null(wcol) && wcol %in% names(bv)) { + bv[, BVweight := as.numeric(bv[[wcol]])] + } else if (!is.null(LWparam)) { + lengthVar_age <- grep("(?i)length", names(bv), value = TRUE, perl = TRUE) + if (length(lengthVar_age) == 0) + stop("LWparam supplied but no length column found in BV.") + bv[, BVweight := LWparam[1] * as.numeric(bv[[lengthVar_age[1]]]) ^ LWparam[2]] + } else { + if (verbose) message("No weight column or LWparam supplied: BVweight set to NA.") + bv[, BVweight := NA_real_] + } bv1 <- bv[ - , .(BVMeanWeight = mean(get(wcol), na.rm = TRUE), + , .(BVMeanWeight = mean(BVweight, na.rm = TRUE), BVNumbersAtAge = .N), by = .(SAid, Age) ][ - # add total count per SAid , BVTotCount := sum(BVNumbersAtAge), by = SAid ][ - # add total weight per SAid - bv[, .(BVTotWeight = sum(get(wcol), na.rm = TRUE)), by = SAid], + bv[, .(BVTotWeight = sum(BVweight, na.rm = TRUE)), by = SAid], on = "SAid" ] - # bv1$BVLengthClassProp <- bv1$BVNumbersAtLength/bv1$TotCount - - - sa <- setDT(RDBESEstRatioObj$SA) - sa <- sa[, unique(.SD), .SDcols = c("SAid", "SAlowHierarchy", "SAtotalWtMes" , "SAsampWtMes", "SAnumTotal", "SAnumSamp", "SAauxVarValue", "SAauxVarUnit" )] # Do not need the - # species, the filtering of the "strata" variables will be done before the estimation - # To test - sa[, SAauxVarValue := as.numeric(SAauxVarValue )] - sa$SAauxVarValue <- 10 - - # TODO add check for subsampling - - su <- merge(bv1, sa, by = c("SAid")) - - if(raiseVar == "Weight"){ - - su$raiseFactor <- su$SAtotalWtMes/su$SAsampWtMes - su$NumbersAtAge <- su$raiseFactor*su$BVNumbersAtAge - - }else if(raiseVar == "Count"){ - - su$raiseFactor <- su$SAnumTotal/su$SAnumSamp - su$NumbersAtAge <- su$raiseFactor*su$BVNumbersAtAge - - }else{ - - su$NumbersAtAge <- su$SAauxVarValue*su$BVNumbersAtAge - + # Mean length at age + lengthVar <- grep("(?i)length", names(bv), value = TRUE, perl = TRUE) + if (length(lengthVar) > 0) { + lv1 <- lengthVar[1] + mean_len <- bv[, .(MeanLengthAtAge = mean(as.numeric(bv[[lv1]]), + na.rm = TRUE)), + by = .(SAid, Age)] + bv1 <- merge(bv1, mean_len, by = c("SAid", "Age"), all.x = TRUE) + } else { + bv1[, MeanLengthAtAge := NA_real_] } - return(su) - # Check which biol data are present - - # if age exists - - # if indv weights + lengths exist - - # then Full data set back - - # if only indv weights - # then you don't have the mean length at age unless you use the inverse LW relationship :provide a, b parameters or model them (Future work) - # if only lengths - # the you don't have the mean weight at age unless LW: a, b or model (Future work) - # else stop you don't sufficient data - - # else stop - + su <- merge(bv1, sa, by = "SAid") + su <- applySARaise(su, + numbersInCol = "BVNumbersAtAge", + numbersOutCol = "NumbersAtAge") -# LH A -------------------------------------------------------------------- - - - }else if(unique(RDBESDataObj$SA$SAlowHierarchy) == "A"){ - - bv <- setDT(RDBESEstRatioObj$BV) - fm <- setDT(RDBESEstRatioObj$FM) - bv <- bv[, unique(.SD), .SDcols = c( "FMid","BVfishId", "BVtypeMeas", "BVvalueMeas")] - bv <- dcast(bv, ... ~ BVtypeMeas , value.var = c("BVvalueMeas"), drop = TRUE) - bv[, `:=`(wcol = as.numeric(wcol ))] - - # if age exists - - # if indv weights + lengths exist - - # then Full data set back - - # if only indv weights - # then you don't have the mean length at age unless you use the inverse LW relationship :provide a, b parameters or model them (Future work) - # if only lengths - # the you don't have the mean weight at age unless LW: a, b or model (Future work) - # else stop you don't sufficient data - - # else stop - - # TODO include FM. For now the FM is not yet implemented + return(su) } } + stop("Unrecognised combination of targetValue ('", targetValue, + "') and lower hierarchy ('", lh, "').") } diff --git a/R/filterRDBESDataObject.R b/R/filterRDBESDataObject.R index f2839b11..babd2248 100644 --- a/R/filterRDBESDataObject.R +++ b/R/filterRDBESDataObject.R @@ -29,13 +29,13 @@ #' @examples #' \dontrun{ #' -#' myH1RawObject <- -#' importRDBESDataCSV(rdbesExtractPath = "tests\\testthat\\h1_v_1_19") +#' data("H1Example") +#' myH1DataObject <- H1Example #' #' myFields <- c("SDctry", "VDctry", "VDflgCtry", "FTarvLoc") #' myValues <- c("ZW", "ZWBZH", "ZWVFA") #' -#' myFilteredObject <- filterRDBESDataObject(myH1RawObject, +#' myFilteredObject <- filterRDBESDataObject(myH1DataObject, #' fieldsToFilter = myFields, #' valuesToFilter = myValues #' ) @@ -43,10 +43,10 @@ #' # Inverse filtering (exclude certain values) #' # Example: keep all DE rows except those with DEid in `excludedValues` #' # Compute the complement of the excluded set using setdiff -#' allValues <- unique(myH1RawObject$DE$DEid) +#' allValues <- unique(myH1DataObject$DE$DEid) #' excludedValues <- c(5351) #' myInverseFiltered <- filterRDBESDataObject( -#' myH1RawObject, +#' myH1DataObject, #' fieldsToFilter = "DEid", #' valuesToFilter = setdiff(allValues, excludedValues) #' ) diff --git a/R/filterRDBESEstObject.R b/R/filterRDBESEstObject.R index ba71e4a1..76b1df44 100644 --- a/R/filterRDBESEstObject.R +++ b/R/filterRDBESEstObject.R @@ -13,6 +13,9 @@ #' @return the filtered input object of the same class as #' `RDBESEstObjectToFilter` #' +#' @section Development review: +#' - AI-assisted: No +#' - Human review: rix133 #' @export #' @md #' @@ -46,10 +49,11 @@ filterRDBESEstObject <- function(RDBESEstObjectToFilter, foundNames <- fieldsToFilter[fieldsToFilter %in% allColNames] if (length(foundNames) > 0) { - RDBESEstObjectToFilter <- - dplyr::filter(RDBESEstObjectToFilter, - dplyr::if_all(all_of(foundNames), ~ .x %in% valuesToFilter) - ) + # Keep the rows where all of the found fields have an allowed value + rowsToKeep <- Reduce(`&`, lapply(foundNames, function(fieldName) { + RDBESEstObjectToFilter[[fieldName]] %in% valuesToFilter + })) + RDBESEstObjectToFilter <- RDBESEstObjectToFilter[rowsToKeep, ] } return(RDBESEstObjectToFilter) diff --git a/R/findAndKillOrphans.R b/R/findAndKillOrphans.R index 96a0f79c..f8394993 100644 --- a/R/findAndKillOrphans.R +++ b/R/findAndKillOrphans.R @@ -1,7 +1,11 @@ +#' Find and kill orphans in an RDBESDataObject +#' #' This function finds and removed any orphan records in an #' RDBESDataObject. Normally data that has been downloaded from the RDBES #' will not contain orphan records - however if the data is subsequently #' filtered it is possible to introduce orphan records. +#' The direction of the cleanup is effectively downstream. +#' The function does not remove parent rows because a child disappeared. #' #' @param objectToCheck an RDBESDataObject. #' @param verbose (Optional) If set to TRUE more detailed text will be printed @@ -15,11 +19,11 @@ #' @examples #' \dontrun{ #' -#' myH1RawObject <- -#' importRDBESDataCSV(rdbesExtractPath = "tests\\testthat\\h1_v_1_19") +#' data("H1Example") +#' myH1DataObject <- H1Example #' myFields <- c("SDctry","VDctry","VDflgCtry","FTarvLoc") #' myValues <- c("ZW","ZWBZH","ZWVFA" ) -#' myFilteredObject <- filterRDBESDataObject(myH1RawObject, +#' myFilteredObject <- filterRDBESDataObject(myH1DataObject, #' fieldsToFilter = myFields, #' valuesToFilter = myValues ) #' myObjectNoOrphans <- findAndKillOrphans(objectToCheck = myFilteredObject, diff --git a/R/findOrphansByTable.R b/R/findOrphansByTable.R index 1f4f77b9..7c2a78d2 100644 --- a/R/findOrphansByTable.R +++ b/R/findOrphansByTable.R @@ -10,6 +10,9 @@ #' @return A data frame with the primary keys of the table checked, the two #' letter table identifier, and their orphan status. #' +#' @section Development review: +#' - AI-assisted: No +#' - Human review: rix133 findOrphansByTable <- function(tableToCheck, objectToCheck, foreignKeyIds, @@ -45,14 +48,16 @@ findOrphansByTable <- function(tableToCheck, if (!is.null(objectToCheck[[fkTable]])) { if (myFK == "SAparSequNum") { # Need to handle SAparSequNum differently - joinedTables <- dplyr::inner_join(myTable, + joinedTables <- joinDT(myTable, objectToCheck[[fkTable]], - by = c("SAseqNum" = "SAparSequNum") + by = c("SAseqNum" = "SAparSequNum"), + type = "inner" ) } else { - joinedTables <- dplyr::inner_join(myTable, + joinedTables <- joinDT(myTable, objectToCheck[[fkTable]], - by = myFK + by = myFK, + type = "inner" ) } diff --git a/R/generateMissingSSRows.R b/R/generateMissingSSRows.R index 13ac2bba..f107c515 100644 --- a/R/generateMissingSSRows.R +++ b/R/generateMissingSSRows.R @@ -13,6 +13,10 @@ #' the validation be strict? The default is TRUE. #' #' @return A data table of SS data with any missing rows added +#' +#' @section Development review: +#' - AI-assisted: No +#' - Human review: rix133 #' @export #' #' @examples @@ -76,11 +80,12 @@ generateMissingSSRows <- function(RDBESDataObject, # Get the unique combinations of SL country, year, and list names mySLUnique <- unique(mySL[,c("SLcou","SLyear","SLspeclistName")]) - mySSSLUnique <- dplyr::inner_join(mySSUnique, - mySLUnique, - by = c("SSyear" = "SLyear", - "SSctry" = "SLcou", - "SSspecListName" = "SLspeclistName")) + mySSSLUnique <- joinDT(mySSUnique, + mySLUnique, + by = c("SSyear" = "SLyear", + "SSctry" = "SLcou", + "SSspecListName" = "SLspeclistName"), + type = "inner") if (nrow(mySSSLUnique) < 1){ stop(paste0("The requested species list is not compatible with the ", @@ -252,7 +257,7 @@ getMissingSSCatchFraction <- function(FOdata, SSdata, catchFra, verbose) { myFOFraction[myFOFraction$FOcatReg == catchFra, "FOcatReg"] <- "Catch" } - myFOSS <- dplyr::left_join( + myFOSS <- joinDT( myFOFraction, SSdata, by = c( diff --git a/R/generateTestTables.R b/R/generateTestTables.R index 3848b988..6c42e160 100644 --- a/R/generateTestTables.R +++ b/R/generateTestTables.R @@ -74,8 +74,8 @@ makeTbl <- function(tblName, #' #' @examples #' \dontrun{ -#' generateTestTbls(c("A", "B", "C"), selMeth = "SRSWOR") -#' generateTestTbls(LETTERS[1:5]) # makes 5 tables with method CENSUS +#' RDBEScore:::generateTestTbls(c("A", "B", "C"), selMeth = "SRSWOR") +#' RDBEScore:::generateTestTbls(LETTERS[1:5]) # makes 5 tables with method CENSUS #' } generateTestTbls <- function(tblNames, prevTbls = list(), ...) { tbl <- makeTbl(tblNames[1], prevTbls, ...) diff --git a/R/generateZerosUsingSL.R b/R/generateZerosUsingSL.R index 9c502213..3f19b29b 100644 --- a/R/generateZerosUsingSL.R +++ b/R/generateZerosUsingSL.R @@ -11,10 +11,10 @@ #' #' @return RDBES data frame where SA was complemented with species looked for #' (sensu in sampling objectives) but not registered in sample +#' @section Development review: +#' - AI-assisted: No +#' - Human review: rix133 #' @export -#' - - generateZerosUsingSL <- function(x, verbose = FALSE, strict = TRUE) { @@ -64,7 +64,7 @@ generateZerosUsingSL <- function(x, # in the following, the max SAid is determined. That SAid + a decimal will constitute the SAid of the new 0 rows # determine upper table (parentIdVar) and its value (parentIdValue) # note, the use of which is an attempt to make this hierarchy independent - there may be better forms to achieve this. - parentIdVar<-c("FOid","TEid","LEid","FTid")[which(!is.na(tmpSS[tmpSS$SLid == targetSLid,c("FOid","TEid","LEid","FTid")]))] + parentIdVar<-c("FOid","TEid","LEid","FTid")[which(!is.na(mySS[mySS$SLid == targetSLid,c("FOid","TEid","LEid","FTid")]))] parentIdValue<-tmpSS[[parentIdVar]][tmpSS$SLid == targetSLid] # associates the parentIdVar to tmpSA tmpSA$parentIdVar<-x[[gsub("id","",parentIdVar)]][[parentIdVar]][match(parentIdValue, x[[gsub("id","",parentIdVar)]][[parentIdVar]])] @@ -99,9 +99,9 @@ generateZerosUsingSL <- function(x, sppFromSL$SLrowNum <- seq.int(nrow(sppFromSL)) # See which species/fraction need adding - sppToAdd <- dplyr::left_join(sppFromSL, SApresent, - by=c("SLcatchFrac" = "SAcatchCat", - "IScommTaxon" = "SAspeCode")) + sppToAdd <- joinDT(sppFromSL, SApresent, + by=c("SLcatchFrac" = "SAcatchCat", + "IScommTaxon" = "SAspeCode")) sppToAdd <- sppToAdd[is.na(sppToAdd$SArowNum),] sppToAdd <- sppToAdd[,c("SLcatchFrac","IScommTaxon")] sppToAdd <- unique(sppToAdd) @@ -120,7 +120,9 @@ generateZerosUsingSL <- function(x, dummyRows$SAstratification <- 'N' dummyRows$SAstratumName <- 'U' dummyRows$SAspeCode<-sppToAdd$IScommTaxon - dummyRows[,c("SAtotalWtLive","SAsampWtLive","SAtotalWtMes","SAsampWtMes","SAspecState")]<-0 + dummyRows[,c("SAtotalWtLive","SAtotalWtMes")] <- NA + dummyRows[,c("SAsampWtLive", "SAsampWtMes")] <-0 + dummyRows$SAspecState <-'Unknown' dummyRows$SAnumTotal <- ifelse(dummyRows$SAunitType=="Individuals", 0, dummyRows$SAnumTotal) dummyRows$SAnumSamp <- ifelse(dummyRows$SAunitType=="Individuals", 0, dummyRows$SAnumSamp) dummyRows$SAselProb <- 1 diff --git a/R/getLinkedDataFromLevel.R b/R/getLinkedDataFromLevel.R index 09263714..7827777e 100644 --- a/R/getLinkedDataFromLevel.R +++ b/R/getLinkedDataFromLevel.R @@ -8,7 +8,9 @@ #' @param level A character string specifying the target table level from which to retrieve linked data. This must be one of the names within the `rdbesTables` object. #' @param verbose Logical flag indicating whether to print detailed information about the data retrieval process. Default is `FALSE`. #' -#' @return The subset of the table at the specified `level`. +#' @return A data.table containing the requested `field` and all columns of the +#' table at `level`, with one row per unique requested value and linked record. +#' Intermediate hierarchy IDs are not added. Column order is not guaranteed. #' #' @examples #' \dontrun{ @@ -26,11 +28,15 @@ #' # Retrieve data from the VS level based on BVfishId from the BV table #' getLinkedDataFromLevel("BVfishId", c("410472143", "410472144"), H8ExampleEE1, "VS", TRUE) #' } +#' @section Development review: +#' - AI-assisted: No +#' - Review: rix133 #' @export getLinkedDataFromLevel <- function(field, values, rdbesTables, level, verbose = FALSE){ # Check if rdbesTables is of class "RDBESDataObject" if(inherits(rdbesTables, "RDBESDataObject")) { + availableTblNames <- names(rdbesTables) rdbesTables <- sort(rdbesTables) } else { stop("rdbesTables must be of class RDBESDataObject") @@ -44,8 +50,34 @@ getLinkedDataFromLevel <- function(field, values, rdbesTables, level, verbose = # Extract the source table abbreviation from the field name sourceTbl <- substr(field, 1, 2) - # Get the list of table names - tblNames <- names(rdbesTables) + #get the hierarchy of the source table + summary_values <- summary(rdbesTables) + hierarchy <- NA + if(!is.null(summary_values$hierarchy)){ + if(length(summary_values$hierarchy)>1){ + stop("Mixed hierarchy RDBESDataObject!", call.=FALSE) + } + hierarchy <- summary_values$hierarchy + } else { + stop(paste0("No hierarchy, RDBESdataObject:\n ")) + } + + # Get the list of table names with optional if needed + tblNames <- getTablesInRDBESHierarchy(hierarchy) + requiredTblNames <- getTablesInRDBESHierarchy( + hierarchy, + includeOptTables = FALSE + ) + + keepTblNames <- c(requiredTblNames, sourceTbl, level) + tblNames <- tblNames[tblNames %in% keepTblNames] + + #stop if tables in the data are missing required tables + missingTbls <- requiredTblNames[!requiredTblNames %in% availableTblNames] + if(length(missingTbls) > 0){ + stop(paste0("Missing required tables in the RDBESDataObject: ", + paste(missingTbls, collapse = ", "))) + } # Determine the positions of sourceTbl and target level in the table list sourcePos <- which(tblNames == sourceTbl) diff --git a/R/getLowerTableSubsets.R b/R/getLowerTableSubsets.R index fe169005..2d8b7b9f 100644 --- a/R/getLowerTableSubsets.R +++ b/R/getLowerTableSubsets.R @@ -21,6 +21,11 @@ #' the values from each subset in the upper tables. It then ensures that only unique rows are returned, #' based on the ID column of the target table. #' +#' @section Development review: +#' - AI-assisted: Yes +#' - Review: rix133 +#' @keywords internal +#' getLowerTableSubsets <- function(subsets, tblName, rdbesTables, combineStrata = TRUE, verbose = FALSE) { res <- list() # Process each subset @@ -66,8 +71,13 @@ getLowerTableSubsets <- function(subsets, tblName, rdbesTables, combineStrata = stop("combineStrata must be TRUE for now") } + # Linked data carries the requested fields - replace them by the strata values below + addedFields <- setdiff(names(subsets), names(rdbesTables[[tblName]])) + res <- res[, setdiff(names(res), addedFields), with = FALSE] + subsets <- subsets[addedFields] + # Combine the data with the strata subsets - res <- cbind(res, as.data.frame(subsets)) + if(length(subsets) > 0) res <- cbind(res, as.data.frame(subsets)) return(res) } diff --git a/R/importRDBESDataCSV.R b/R/importRDBESDataCSV.R index 9ae3e114..ae1ee11c 100644 --- a/R/importRDBESDataCSV.R +++ b/R/importRDBESDataCSV.R @@ -23,13 +23,19 @@ #' it will contain the data from those files. If no path is supplied then #' an empty RDBESDataObject will be returned. #' +#' @section Development review: +#' - AI-assisted: No +#' - Review: rix133 +#' - Notes/scope: Added tests dealing with over integer limit +#' #' @examples #' \dontrun{ -#' myEmptyRDBESObject <- importRDBESDataCSV() -#' rdbesExtractPath <- "./tests/testthat/h7_v_1_19_18/" -#' obj <- importRDBESDataCSV(rdbesExtractPath) -#' } - +#' dataDir <- paste0(system.file("extdata", package = "RDBEScore"), "/") +#' tmpDir<-tempdir(check = FALSE) +#' unzip(paste0(dataDir,"H1_Example.zip"), exdir=tmpDir) +#' myH1DataObject<-RDBEScore:::importRDBESDataCSV(file.path(tmpDir,"H1")) +#' validateRDBESDataObject(myH1DataObject)} +#' importRDBESDataCSV <- function(rdbesExtractPath = NULL, listOfFileNames = NULL, castToCorrectDataTypes = TRUE, @@ -82,6 +88,10 @@ importRDBESDataCSV <- function(rdbesExtractPath = NULL, fieldsFormat <- RDBEScore::mapColNamesFieldR[ RDBEScore::mapColNamesFieldR$Table.Prefix == myFile, "RDataType"] + #to account for the possible long numeric fields in all integer fields + #because the id numbers may get wery long at one point + fieldsFormat <- ifelse(fieldsFormat == "integer", "numeric", fieldsFormat) + # Read the file with error handling so we can raise a clear message filePath <- paste(rdbesExtractPath, "/", fileNames[myFile], sep = "") csvBaseName <- sub("\\.csv$", "", fileNames[myFile]) @@ -93,7 +103,7 @@ importRDBESDataCSV <- function(rdbesExtractPath = NULL, quote = "", stringsAsFactors = FALSE, colClasses = fieldsFormat - ), + ), silent = TRUE ) diff --git a/R/importRDBESDataZIP.R b/R/importRDBESDataZIP.R index b8f29b0c..e4035d81 100644 --- a/R/importRDBESDataZIP.R +++ b/R/importRDBESDataZIP.R @@ -22,10 +22,10 @@ #' #' @examples #' \dontrun{ -#' rdbesExtractPath <- "./2022_FPN_FPE_H7.zip" -#' obj <- importRDBESDataZIP(rdbesExtractPath) -#' } - +#' dataDir <- paste0(system.file("extdata", package = "RDBEScore"), "/") +#' myH1DataObject <- RDBEScore:::importRDBESDataZIP(file.path(dataDir,"H1_Example.zip")) +#' validateRDBESDataObject(myH1DataObject)} +#' importRDBESDataZIP <- function(filenames, castToCorrectDataTypes = TRUE, Hierarchy = NULL, ...) { diff --git a/R/joinDT.R b/R/joinDT.R new file mode 100644 index 00000000..4338c3af --- /dev/null +++ b/R/joinDT.R @@ -0,0 +1,77 @@ +#' Join two tables using data.table +#' +#' Internal replacement for `dplyr::left_join()`, `dplyr::inner_join()` and +#' `dplyr::right_join()`, built on `data.table::merge()` with `sort = FALSE`. +#' The output follows dplyr's conventions: +#' * rows are returned in the order of `x`, each `x` row followed by all its +#' matching `y` rows in the order they appear in `y`. A right join appends +#' the unmatched `y` rows at the end; +#' * columns are the columns of `x` followed by the non-key columns of `y`; +#' * non-key columns found in both tables get `suffix` added to their names; +#' * `NA` key values match each other and many-to-many matches return all +#' combinations; +#' * an integer key joined to a double key gives a double key. +#' +#' Differences from dplyr: if a suffixed name is already taken, `joinDT()` +#' gives an error (dplyr adds the suffix again). Other combinations of key +#' types follow data.table's join rules (e.g. a factor or logical key keeps the +#' type and levels of `x`, and joining factor or logical keys to other types +#' can give an error). +#' +#' The input tables are not modified. +#' +#' @param x,y data.frames or data.tables to join. +#' @param by Character vector of key column names. Use a named vector, e.g. +#' `c("SSyear" = "SLyear")`, when the key columns have different names in +#' `x` (names) and `y` (values). Only the `x` key columns are kept. +#' @param type The type of join: `"left"` keeps all rows of `x`, `"inner"` +#' keeps only matching rows and `"right"` keeps all rows of `y`. +#' @param suffix Character vector of length 2 added to the names of non-key +#' columns found in both `x` and `y`. Use `""` to keep the names of one +#' table unchanged. +#' +#' @return A data.table if `x` is a data.table, otherwise a data.frame. +#' +#' @section Development review: +#' - AI-assisted: Yes +#' - Human review: rix133 +#' - Notes/scope: Written to remove the dplyr dependency. Tested on +#' every join made by the package test suite (~12k joins currently). +#' +#' @keywords internal +joinDT <- function(x, y, by, type = c("left", "inner", "right"), + suffix = c(".x", ".y")) { + type <- match.arg(type) + yBy <- unname(by) + xBy <- if (is.null(names(by))) yBy else ifelse(names(by) == "", yBy, names(by)) + + # convert first: merge() on a data.frame would dispatch to base R's merge(). + # A merge() warning (e.g. duplicated column names) is turned into an error + out <- withCallingHandlers( + merge(data.table::as.data.table(x), data.table::as.data.table(y), + by.x = xBy, by.y = yBy, + all.x = type == "left", all.y = type == "right", + sort = FALSE, suffixes = suffix, allow.cartesian = TRUE), + warning = function(w) stop(conditionMessage(w), call. = FALSE)) + + # merge() returns the keys, the other x columns and the other y columns; + # restore the column order of x + xNames <- names(x) + isKey <- xNames %in% xBy + xNames[!isKey] <- names(out)[length(xBy) + seq_len(sum(!isKey))] + data.table::setcolorder(out, xNames) + + # like dplyr, use a double key if the key is double in either table + # (merge() can turn a double x key into integer when matching integer y) + # this is needed because of Large ids. as.integer.or.dbl() stores an integer + # id column as double if any value is above 2e9 (R's 32-bit integer limit) + # It decides per column, so the same id can be integer in one table and double in another. + for (k in seq_along(xBy)) { + if (is.integer(out[[xBy[k]]]) && + (is.double(x[[xBy[k]]]) || is.double(y[[yBy[k]]]))) { + data.table::set(out, j = xBy[k], value = as.double(out[[xBy[k]]])) + } + } + if (!data.table::is.data.table(x)) data.table::setDF(out) + out +} diff --git a/R/lowerTblData.R b/R/lowerTblData.R index 8f539bfa..2f243fb5 100644 --- a/R/lowerTblData.R +++ b/R/lowerTblData.R @@ -11,12 +11,18 @@ #' @param tbls A named list of data frames representing the tables. #' @param level A character string specifying the name of the target lower level table. #' @param verbose A logical value indicating whether to print intermediate levels during recursion. -#' @param path_order Internal: character vector tracking the traversal path of IDs during -#' recursion to preserve a stable column order in the returned result. Users should not -#' normally set this; it is maintained by recursive calls (default NULL). +#' @param requestedField Internal: the originally requested field, carried +#' through the recursion (default `field`). +#' @param requestedValues Internal: the originally requested value belonging to +#' each element of `values`, carried through the recursion (default `values`). #' -#' @return A data frame containing the rows of the target lower level table that are associated with -#' the given values of the upper table field. +#' @return A data.table with the originally requested field and all columns of +#' the `level` table. No intermediate hierarchy IDs are added. It has one row +#' per unique requested value and linked `level` record. +#' +#' @section Development review: +#' - AI-assisted: Yes +#' - Review: rix133 #' #' @examples #' # it is important to run the function only on the sorted RDBESDataObject @@ -31,73 +37,53 @@ #' #' RDBEScore:::lowerTblData("TEid", c(4), tblsSprat, "LE", TRUE) #' @keywords internal -lowerTblData <- function(field, values, tbls, level, verbose = FALSE, path_order = NULL) { - if(!is.list(tbls)) stop("tbls must be a list") +lowerTblData <- function(field, values, tbls, level, verbose = FALSE, + requestedField = field, requestedValues = values) { + if (!is.list(tbls)) stop("tbls must be a list") + if (!level %in% names(tbls)) stop("Missing table in data: ", level) - start <- substr(field, start = 1, stop = 2) - if (start == level) { - res <- tbls[[level]] - return(res[get(field) %in% values]) - } - currTbl <- which(start == names(tbls)) + current <- substr(field, 1, 2) + i <- match(current, names(tbls)) + if (is.na(i)) stop("Missing table: ", current) - # assumes tables are in correct order and no empty tables - tc <- 1 - nextTbl <- tbls[[currTbl + tc]] - while (is.null(nextTbl)) { - tc <- tc + 1 - if(currTbl + tc > length(tbls)) stop("No more lower tables found") - nextTbl <- tbls[[currTbl + tc]] - } + # Keep track of original requested values + mapping <- unique(data.table::data.table( + .currentValue = values, + .requestedValue = requestedValues + )) - nextTblField <- paste0(names(tbls)[currTbl + tc], "id") - if (verbose) { - cat(paste0(field, ": ", paste0(values, collapse = ", "), "\n")) - } - if (!field %in% colnames(nextTbl)) { - tbl <- tbls[[currTbl]] - curTblId <- paste0(names(tbls)[currTbl], "id") - values <- tbl[get(field) %in% values, get(curTblId)] - field <- curTblId - } - - # Initialize and update path order to ensure the original search field stays first - if (is.null(path_order)) path_order <- field - path_order <- unique(c(path_order, nextTblField)) + result <- merge(mapping, tbls[[current]], + by.x = ".currentValue", by.y = field, + sort = FALSE, allow.cartesian = TRUE) + data.table::setnames(result, ".currentValue", field) - # values in next table for recursion - nextTblValues <- nextTbl[get(field) %in% values, get(nextTblField)] + if (current != level) { + if (verbose) cat(field, ": ", paste(values, collapse = ", "), "\n", sep = "") - # NEW: build link (current id -> next id) so we can keep intermediate IDs - linkDT <- unique(nextTbl[get(field) %in% values, - .(from = get(field), to = get(nextTblField))]) - data.table::setnames(linkDT, c("from","to"), c(field, nextTblField)) + # Find the nearest following non-empty table in hierarchy order + candidates <- seq_along(tbls)[-seq_len(i)] + candidates <- candidates[vapply(tbls[candidates], NROW, integer(1)) > 0L] + if (!length(candidates)) stop("No more lower tables found") - # recurse - res <- lowerTblData(nextTblField, nextTblValues, tbls, level, verbose, path_order) + nextName <- names(tbls)[min(candidates)] + idField <- paste0(current, "id") + nextField <- paste0(nextName, "id") + if (!all(c(idField, nextField) %in% names(tbls[[nextName]]))) { + stop("Error in linking tables ", current, " and ", nextName) + } - # NEW: merge link back so the current level's ID is preserved - # Always attach the authoritative parent id from the link. - # If a column with the same name already exists (from another variant), drop it first, - # then merge in the value derived from the current hierarchy. - if (field %in% names(res)) { - res[, (field) := NULL] + result <- result[, c(idField, ".requestedValue"), with = FALSE] + result <- merge(result, tbls[[nextName]][, c(idField, nextField), with = FALSE], + by = idField, sort = FALSE, allow.cartesian = TRUE) + return(lowerTblData( + nextField, result[[nextField]], tbls, level, + verbose, requestedField, result[[".requestedValue"]] + )) } - res <- merge( - linkDT[, c(nextTblField, field), with = FALSE], - res, - by = nextTblField, - all.y = TRUE, - allow.cartesian = TRUE - ) - - #keep path columns toward the front with stable overall path order - path_cols <- intersect(path_order, names(res)) - other_cols <- setdiff(names(res), path_cols) - if (length(path_cols) > 0) data.table::setcolorder(res, c(path_cols, other_cols)) - # Ensure no data.table key is set on the result - data.table::setkeyv(res, NULL) + if (requestedField %in% names(result)) result[, (requestedField) := NULL] + data.table::setnames(result, ".requestedValue", requestedField) + data.table::setcolorder(result, c(requestedField, setdiff(names(result), requestedField))) - res + result } diff --git a/R/removeBrokenSpeciesListLinks.R b/R/removeBrokenSpeciesListLinks.R index 31a70398..6be46d06 100644 --- a/R/removeBrokenSpeciesListLinks.R +++ b/R/removeBrokenSpeciesListLinks.R @@ -1,25 +1,28 @@ -#' Remove rows which are not pointing to a valid SpecliestListDetails (SL) -#' records i.e.those rows which have a value of SpeciesListName that does not -#' exist in the SL table. +#' Remove SS rows with broken species-list links +#' +#' A species-list link matches the list name, catch fraction, design year +#' and sampling country against the SL table. #' #' @param objectToCheck an RDBESDataObject. #' @param verbose (Optional) If set to TRUE more detailed text will be printed -#' out by the function. Default is TRUE. +#' out by the function. Default is FALSE. #' @param strict (Optional) This function validates its input data - should #' the validation be strict? The default is TRUE. #' -#' @return an RDBESDataObject with any records with an invalid SpeciesListName -#' rows removed +#' @return an RDBESDataObject with SS rows without a matching SL record removed. +#' @section Development review: +#' - AI-assisted: Yes +#' - Review: rix133 #' @export #' #' @examples #' \dontrun{ #' -#' myH1RawObject <- -#' importRDBESDataCSV(rdbesExtractPath = "tests\\testthat\\h1_v_1_19") +#' data("H1Example") +#' myH1DataObject <- H1Example #' myFields <- c("SLspeclistName") #' myValues <- c("WGRDBES-EST TEST 5 - sprat data") -#' myFilteredObject <- filterRDBESDataObject(myH1RawObject, +#' myFilteredObject <- filterRDBESDataObject(myH1DataObject, #' fieldsToFilter = myFields, #' valuesToFilter = myValues #' ) @@ -29,127 +32,37 @@ #' ) #' } removeBrokenSpeciesListLinks <- function(objectToCheck, - verbose = FALSE, - strict = TRUE) { - - - # Check we have a valid RDBESDataObject before doing anything else + verbose = FALSE, + strict = TRUE) { validateRDBESDataObject(objectToCheck, verbose = verbose, strict = strict) - # Just check the non-null entries - nonNullEntries <- names(objectToCheck[sapply(objectToCheck, Negate(is.null))]) - - if (!"SL" %in% nonNullEntries){ + if (is.null(objectToCheck[["SL"]])) { stop(paste0("The SL entry in in objectToCheck is null - ", - "cannot check for broken species list links")) - } - - # Only SS links to the species list table - tableToCheck <- "SS" - - # Check any non-null tables - if (tableToCheck %in% nonNullEntries) { - - if (verbose){ - print(paste0( - "Number of rows in relevent non-null tables before removing ", - "broken species list links" - )) - print(unlist(lapply(objectToCheck[tableToCheck], nrow))) - } - - myTable <- objectToCheck[[tableToCheck]] - - # if we have the possibility of orphans - let's check for them - if (nrow(myTable) > 0) { - if (verbose) { - print(paste0( - "Checking for broken species list links in table ", - tableToCheck - )) - } - - # Create a data frame to hold the results - myOrphanResults <- data.table::data.table(myTable[, 1]) - names(myOrphanResults) <- c("pk") - myOrphanResults$Table <- tableToCheck - # Default to link not existing - myOrphanResults[, "slExists"] <- FALSE - - -# Add year and country to SS ---------------------------------------------------- - -myTable$SSyear <- extractHigherFields(objectToCheck, "SS", "DEyear") -myTable$SSctry <- extractHigherFields(objectToCheck, "SS", "SDctry") - -# ------------------------------------------------------------------------- - - - # Inner join to the SL table - joinedTables <- dplyr::inner_join(myTable, - objectToCheck[["SL"]], - by = c("SSspecListName" = "SLspeclistName", - "SScatchFra" = "SLcatchFrac", - "SSyear" = "SLyear", - "SSctry" = "SLcou"), - multiple = "all", - relationship="many-to-many" - ) - - -# Remove year and ctry columns from SS ------------------------------------ - -myTable <- myTable[, SSyear := NULL] -myTable <- myTable[, SSctry := NULL] - -# ------------------------------------------------------------------------- - - - # Remove year and ctry columns from SL - - - # Update the results for any matches we found - if (nrow(joinedTables) > 0) { - - # Find which PKs are in the joined table - these are matches - myOrphanResults[ - myOrphanResults[[1]] %in% joinedTables[[1]], - "slExists" - ] <- TRUE - } - - # We want to remove any rows where the record did not exist in VD - rowsToRemove <- myOrphanResults[!myOrphanResults$slExists, 1] - rowsToRemove <- rowsToRemove[[1]] - - if (verbose) { - print(paste0( - "Found ", length(rowsToRemove), - " records with broken species list links" - )) - } - - # Just keep the rows that aren't in the list to remove - objectToAlter <- myTable - objectToAlter <- - objectToAlter[!objectToAlter[[1]] %in% rowsToRemove, ] - - objectToCheck[[tableToCheck]] <- objectToAlter - - if (verbose) { - print(paste0("Records with broken species list links have been removed")) - } - } + "cannot check for broken species list links")) } - if (verbose){ - print(paste0( - "Number of rows in relevent non-null tables after removing ", - "broken species list links" - )) - print(unlist(lapply(objectToCheck[tableToCheck], nrow))) + mySS <- objectToCheck[["SS"]] + if (is.null(mySS) || nrow(mySS) == 0L) return(objectToCheck) + + myLinks <- data.table::data.table( + SLspeclistName = mySS[["SSspecListName"]], + SLcatchFrac = mySS[["SScatchFra"]], + SLyear = extractHigherFields(objectToCheck, "SS", "DEyear"), + SLcou = extractHigherFields(objectToCheck, "SS", "SDctry") + ) + # One match per SS row is sufficient, even when several SL records match. + myMatches <- objectToCheck[["SL"]][myLinks, + on = c("SLspeclistName", "SLcatchFrac", "SLyear", "SLcou"), + which = TRUE, mult = "first"] + hasMatch <- !is.na(myMatches) + + if (verbose) { + print(paste0("SS rows before: ", nrow(mySS), + "; removed: ", sum(!hasMatch), + "; remaining: ", sum(hasMatch))) } - return(objectToCheck) + objectToCheck[["SS"]] <- mySS[hasMatch] + objectToCheck } diff --git a/R/removeBrokenVesselLinks.R b/R/removeBrokenVesselLinks.R index 3f09bfd9..fa37efde 100644 --- a/R/removeBrokenVesselLinks.R +++ b/R/removeBrokenVesselLinks.R @@ -8,16 +8,19 @@ #' the validation be strict? The default is TRUE. #' #' @return an RDBESDataObject with any records with an invalid VDid removed +#' @section Development review: +#' - AI-assisted: No +#' - Human review: rix133 #' @export #' #' @examples #' \dontrun{ #' -#' myH1RawObject <- -#' importRDBESDataCSV(rdbesExtractPath = "tests\\testthat\\h1_v_1_19") +#' data("H1Example") +#' myH1DataObject <- H1Example #' myFields <- c("VDlenCat") #' myValues <- c("18-<24") -#' myFilteredObject <- filterRDBESDataObject(myH1RawObject, +#' myFilteredObject <- filterRDBESDataObject(myH1DataObject, #' fieldsToFilter = myFields, #' valuesToFilter = myValues #' ) @@ -82,9 +85,10 @@ removeBrokenVesselLinks <- function(objectToCheck, myOrphanResults[, "vdExists"] <- FALSE # Inner join to the VD table - joinedTables <- dplyr::inner_join(myTable, + joinedTables <- joinDT(myTable, objectToCheck[["VD"]], - by = "VDid" + by = "VDid", + type = "inner" ) # Update the results for any matches we found diff --git a/R/updateSAwithTaxonFromSL.R b/R/updateSAwithTaxonFromSL.R index 076fa3cd..dc17cba4 100644 --- a/R/updateSAwithTaxonFromSL.R +++ b/R/updateSAwithTaxonFromSL.R @@ -24,7 +24,9 @@ #' occuring in SL for level of species rank. If in SA is #' Sprat(126425), in SL Clupeidae (125464) function renameSpeciesSA rename Sprat #' from SA to Clupeidae. Clupeidae(family rank) is higher rank than Sprat(species rank). -#' +#'@section Development review: +#' - AI-assisted: No +#' - Human review: rix133 #' @export #' #' @examples @@ -56,26 +58,26 @@ updateSAwithTaxonFromSL <- function(RDBESDataObject, # 1st # Append ahpia records to SA data - H1_SA_new <- dplyr::left_join(H1_SA, + H1_SA_new <- joinDT(H1_SA, aphiaRecords, by = c("SAspeCode" = "AphiaID") ) # Append ahpia records to IS data #H1_SL$SLsppCode <- as.character(H1_SL$SLsppCode) - #H1_SL_new <- dplyr::left_join(H1_SL, + #H1_SL_new <- joinDT(H1_SL, # aphiaRecords, # by = c("SLsppCode" = "AphiaID") #) H1_IS$ISsppCode <- as.character(H1_IS$ISsppCode) - H1_IS_new <- dplyr::left_join(H1_IS, - aphiaRecords, - by = c("ISsppCode" = "AphiaID") + H1_IS_new <- joinDT(H1_IS, + aphiaRecords, + by = c("ISsppCode" = "AphiaID") ) # Combine SL with IS - H1_SL_new <- dplyr::left_join(H1_SL, - H1_IS_new, - by = "SLid") + H1_SL_new <- joinDT(H1_SL, + H1_IS_new, + by = "SLid") # SS only information about SLspecieslistName diff --git a/R/upperTblData.R b/R/upperTblData.R index 9bb62ad9..8897d6f3 100644 --- a/R/upperTblData.R +++ b/R/upperTblData.R @@ -17,47 +17,75 @@ #' @param tbls A named list of data frames containing tables at different levels. #' @param level A character string specifying the level to get data from. #' @param verbose (Optional) Set to TRUE if you want informative text printed +#' @param requestedField Internal: the originally requested field. +#' @param requestedValues Internal: the original value for each element of `values`. #' #' @return A data frame containing rows from an upper table that match the #' provided values for the specified field. #' +#' @section Development review: +#' - AI-assisted: Yes +#' - Review: rix133 +#' #' @examples #' # it is important to run these functions only on sorted RDBESDataObject #' RDBEScore:::upperTblData("SAid", c(1), sort(H8ExampleEE1), "DE", verbose = TRUE) #' DE <- data.table::data.table(DEid = c(1, 2)) #' SD <- data.table::data.table(SDid = c(1, 2), DEid = c(1, 2)) -#' VS <- data.table::data.table(VSid = c(1, 2),SDid =c(1,2), value = c(10, 20)) +#' VS <- data.table::data.table(VSid = c(1, 2),SDid =c(1,2), VSvalue = c(10, 20)) #' tbls <- list(DE = DE, SD = SD, VS = VS) #' RDBEScore:::upperTblData("VSid", c(1), tbls, "DE") #' @keywords internal -upperTblData <- function(field, values, tbls, level, verbose = FALSE){ - #check if tables are of correct type - if(!is.list(tbls)) stop("tbls must be a list") - if(!level %in% names(tbls)) stop(level, " must be a character string in the names of the tables") - - start <- substr(field, start=1, stop=2) - if(start == level){ - res <- tbls[[level]] - return(res[get(field) %in% values,]) - } - tbl <- tbls[[start]] - currTbl <- which(start == names(tbls)) - if(verbose){ - print(paste0(start,": ", paste0(values, collapse = ", "))) +upperTblData <- function(field, values, tbls, level, verbose = FALSE, + requestedField = field, requestedValues = values) { + + if (!is.list(tbls)) stop("tbls must be a list") + if (!level %in% names(tbls)) stop("Missing table in data: ", level) + + current <- substr(field, 1, 2) + i <- match(current, names(tbls)) + if (is.na(i)) stop("Missing table: ", current) + + # Keep track of original requested IDs + mapping <- unique(data.table::data.table( + .currentValue = values, + .requestedValue = requestedValues + )) + + # Match rows at the current level + result <- merge(mapping, tbls[[current]], + by.x = ".currentValue", by.y = field, + sort = FALSE, allow.cartesian = TRUE) + + # Continue recursively until the target level is reached + if (current != level) { + if (verbose) message(current, ": ", paste(values, collapse = ", ")) + + # Find the nearest preceding non-empty table + candidates <- seq_len(i - 1L) + candidates <- candidates[vapply(tbls[candidates], NROW, integer(1)) > 0L] + if (!length(candidates)) stop("No upper table found for ", current) + + parentField <- paste0(names(tbls)[max(candidates)], "id") + + return(upperTblData( + parentField, result[[parentField]], tbls, level, + verbose, requestedField, result[[".requestedValue"]] + )) } - #skip NULL tables - tc <- -1 - prevTbl <- names(tbls)[currTbl+tc] - while(is.null(tbls[[prevTbl]])){ - if(verbose){ - print(paste0("Skipping: ", prevTbl)) - } - tc <- tc - 1 - if((currTbl+tc) < 1) stop("No table found") - prevTbl <- names(tbls)[currTbl+tc] + # Restore column names at the target level + data.table::setnames(result, ".currentValue", field) + + if (requestedField %in% names(result)) { + data.table::set(result, j = requestedField, value = result[[".requestedValue"]]) + result[, .requestedValue := NULL] + } else { + data.table::setnames(result, ".requestedValue", requestedField) + data.table::setcolorder( + result, c(requestedField, setdiff(names(result), requestedField)) + ) } - prevTblfield <- paste0(names(tbls)[currTbl+tc], "id") - prevTblvalues <- tbl[get(field) %in% values, get(prevTblfield)] - upperTblData(prevTblfield,prevTblvalues, tbls[1:currTbl], level, verbose) + + result } diff --git a/R/utils.R b/R/utils.R index 0e982554..0551875c 100644 --- a/R/utils.R +++ b/R/utils.R @@ -10,7 +10,7 @@ usedVars <- c("mapColNamesFieldR", "..varsNeeded", "|>", "parentTableID", "est.total", "recType", "parentTableStratum", "stratumName", "parentIDandStratum", "studyVariable", "..myColNames", - "..methColNames", "tblName", "all_of", "SLid","SAid", + "..methColNames", "tblName", "SLid","SAid", "..myLevel","parentTable",".", "id", "i.id" ) moreUsedVars <- c("..clustFields", "DEyear", "SAcatchCat", @@ -49,7 +49,7 @@ globalVariables(unique(c(usedVars, moreUsedVars, evenMoreUsedVars))) #' @return a vector of integers or doubles #' @importFrom stats na.omit #' @keywords internal - +#' @exportS3Method NULL as.integer.or.dbl <- function(x){ # we apply as.numeric in case it is a character vector # we apply as.omit because that causes an error @@ -142,66 +142,76 @@ convert.col.names <- function(table, new.names = "R.name"){ return(nms.new) } -# Convert all elements of a list of data.frames into data.tables -# Leaves existing NULL elements as NULL +#' makeDT +#' +#' Converts one element of a list of data.frames into a data.table, leaving +#' `NULL` elements as `NULL`. Used for each RDBES table in +#' `importRDBESDataDFS()`. +#' +#' @param x A data.frame, or `NULL`. +#' +#' @return A data.table, or `NULL` if `x` is `NULL`. +#' @keywords internal makeDT <- function(x){ if(is.null(x)) return(NULL) data.table::as.data.table(x) } -# Gets data from higher in the hierarchy for the given input `table`. Only SS -# explicitly supported for now, but could update in the future to support any -# table (in theory). -# -# `object` = an RDBESDataObject -# -# `table` = The table from which to start and go up the hierarchy (e.g. `"SS"`) -# -# `field` = The data (column name) to extract from any other table higher in the -# hierarchy, e.g. `"DEyear"` or `"SDctry"`. -# -# At present will not work with data which contains more than one hierarchy. -# Also bypasses any optional tables (e.g. FT in H5). -# e.g. extractHigherFields(myRDBESObject, "SS", "DEyear") - +#' extractHigherFields +#' +#' Gets data from higher in the hierarchy for the given input `table`. Only SS +#' explicitly supported for now, but could update in the future to support any +#' table (in theory). +#' +#' At present will not work with data which contains more than one hierarchy. +#' Also bypasses any optional tables (e.g. FT in H5). +#' +#' @param object An RDBESDataObject. +#' @param table The table from which to start and go up the hierarchy +#' (e.g. `"SS"`). +#' @param field The data (column name) to extract from any other table higher +#' in the hierarchy, e.g. `"DEyear"` or `"SDctry"`. +#' +#' @return One value per row of `table`, in the same order. Rows that are not +#' linked to the table holding `field` get `NA` (e.g. orphans left by +#' filtering DE before `findAndKillOrphans()` runs in +#' `filterAndTidyRDBESDataObject()`). +#' +#' @section Development review: +#' - AI-assisted: Yes +#' - Human review: rix133 +#' +#' @examples +#' \dontrun{ +#' RDBEScore:::extractHigherFields(H1Example, "SS", "DEyear") +#' } +#' @keywords internal extractHigherFields <- function(object, table, field){ # Check for a single hierarchy - if(length(unique(object$DE$DEhierarchy)) == 1) - hierarchy <- paste0("H", unique(object$DE$DEhierarchy)) else - stop("Multiple Upper Hierarchies found.") - - # object hierarchy - h <- paste0("H", unique(object$DE$DEhierarchy)) - - # get path from DE to input table - h.all <- tablesInRDBESHierarchies |> - dplyr::filter(h == hierarchy) |> - dplyr::arrange(sortOrder) |> - dplyr::filter(FALSE == optional) |> - dplyr::filter(FALSE == lowerHierarchy) - path.to.table <- h.all$table - path.to.table <- path.to.table[match("DE", path.to.table):match(table, path.to.table)] # path to SS - - # Always start with joining DE and SD - joined_tbl <- dplyr::left_join(object$SD, # 2nd table - object$DE, # 1st table - by = "DEid", - suffix = c('', '.y')) # ensures the second table names are not changed, otherwise the next join might fail - - for(i in 3:length(path.to.table)){ # 3 since first 2 tables always DE and SD - - # Join to next table in path - joined_tbl <- dplyr::inner_join(object[[path.to.table[i]]], # next table - joined_tbl, - by = paste0(path.to.table[i-1], "id"), # previous table id column - suffix = c('', '.y')) + hierarchy <- unique(object$DE$DEhierarchy) + if (length(hierarchy) != 1) stop("Multiple Upper Hierarchies found.") + + # path from DE to the input table, without optional and lower hierarchy tables + path.to.table <- getTablesInRDBESHierarchy(hierarchy, + includeOptTables = FALSE, + includeLowHierTables = FALSE) + path.to.table <- path.to.table[match("DE", path.to.table):match(table, path.to.table)] + missingTables <- path.to.table[sapply(object[path.to.table], is.null)] + if (length(missingTables) > 0) stop("Tables not found in the object: ", paste(missingTables, collapse = ", ")) + + # Walk up the path from `table`, following each row to its parent row with + # match(), until reaching the first table that has the field + rows <- seq_len(nrow(object[[table]])) + for (i in rev(seq_along(path.to.table))) { + tbl <- object[[path.to.table[i]]] + if (field %in% names(tbl)) return(tbl[[field]][rows]) + if (i == 1) break + parentId <- paste0(path.to.table[i - 1], "id") + parentIds <- object[[path.to.table[i - 1]]][[parentId]] + if (anyDuplicated(parentIds) > 0) stop("Duplicated ", parentId, " values in table ", path.to.table[i - 1]) + rows <- match(tbl[[parentId]][rows], parentIds, incomparables = NA) } - - # Output column - if(!(field %in% names(joined_tbl))) stop("'field' not found in higher tables column names") else - output <- joined_tbl[[which(names(joined_tbl) == field)]] - - return(output) + stop("'field' not found in higher tables column names") } diff --git a/R/validateRDBESDataObject.R b/R/validateRDBESDataObject.R index 2686816c..c79f12ed 100644 --- a/R/validateRDBESDataObject.R +++ b/R/validateRDBESDataObject.R @@ -29,10 +29,9 @@ #' @aliases checkRDBESDataObject #' @examples #' \dontrun{ -#' myH1RawObject <- -#' importRDBESDataCSV(rdbesExtractPath = "tests/testthat/h1_v_1_19") -#' validateRDBESDataObject(myH1RawObject)} -#' +#' dataDir <- paste0(system.file("extdata", package = "RDBEScore"), "/") +#' myH1DataObject <- createRDBESDataObject(input = paste0(dataDir,"H1_Example.zip")) +#' validateRDBESDataObject(myH1DataObject)} validateRDBESDataObject <- function(objectToCheck, checkDataTypes = FALSE, verbose = FALSE, diff --git a/R/validateRDBESDataObjectDataTypes.R b/R/validateRDBESDataObjectDataTypes.R index b72e418c..84382ea9 100644 --- a/R/validateRDBESDataObjectDataTypes.R +++ b/R/validateRDBESDataObjectDataTypes.R @@ -6,6 +6,9 @@ #' #' @return A data frame containing any data type differences (an empty data #' frame if there are no differences) +#' @section Development review: +#' - AI-assisted: No +#' - Human review: rix133 #' validateRDBESDataObjectDataTypes <- function(objectToCheck){ @@ -41,8 +44,8 @@ validateRDBESDataObjectDataTypes <- function(objectToCheck){ # Compare the two lists of column data types myColCompare <- - dplyr::inner_join(myRequiredCols,myActualCols, - by=c("R.Name"="FieldName")) + joinDT(myRequiredCols,myActualCols, + by=c("R.Name"="FieldName"), type = "inner") # Get the rows that are different (ignoring the rows where we don't # know the data types) diff --git a/R/validateRDBESEstObject.R b/R/validateRDBESEstObject.R index fa504cee..2d7f2334 100644 --- a/R/validateRDBESEstObject.R +++ b/R/validateRDBESEstObject.R @@ -10,9 +10,9 @@ #' #' @examples #' \dontrun{ -#' myH1RawObject <- -#' importRDBESDataCSV(rdbesExtractPath = "tests/testthat/h1_v_1_19") -#' myEStObj <- createRDBESEstObject(myH1RawObject,1) +#' dataDir <- paste0(system.file("extdata", package = "RDBEScore"), "/") +#' myH1DataObject <- createRDBESDataObject(input = paste0(dataDir,"H1_Example.zip")) +#' myEStObj <- createRDBESEstObject(myH1DataObject,1) #' validateRDBESEstObject(myEStObj)} validateRDBESEstObject <- function(objectToCheck, verbose = FALSE){ diff --git a/README.md b/README.md index 723e22fa..a540bfc6 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![CRAN Total](http://cranlogs.r-pkg.org/badges/grand-total/RDBEScore)](https://cran.r-project.org/package=RDBEScore) --> -[ICES Logo](http://ices.dk) +[ICES Logo](http://ices.dk) `RDBEScore` ========= @@ -32,7 +32,7 @@ install.packages("RDBEScore") ``` --> -The most recent production version of the package can be installed from ICES tools (production). Theese are +The most recent production version of the package can be installed from ICES tools (production). These are tools that are operational and maintained by the ICES Secretariat. ```R @@ -52,7 +52,7 @@ install_github("ices-tools-dev/RDBEScore", build_vignettes = TRUE) Usage ----- -For a summary of the package see the following [Vignettes](): +For a summary of the package see the following [Vignettes](https://ices-tools-dev.github.io/RDBEScore/): ```R browseVignettes(package = "RDBEScore") @@ -62,7 +62,7 @@ References ---------- * Regional Database & Estimation System: -https://sboxrdbes.ices.dk/ +https://rdbes.ices.dk/ * Working Group on Governance of the Regional Database & Estimation System: https://www.ices.dk/community/groups/Pages/WGRDBESGOV.aspx @@ -94,46 +94,164 @@ If the installation fails due to R CMD, this alternative option can be used library(remotes) install_github("ices-tools-dev/RDBEScore@dev", build = FALSE) ``` -## On `data.table` usage -Objects of type `data.table` passed as parameters should be copied before modification. As an example: +## How to Start developing + +Contributions are welcome and the use of AI coding tools are permitted, but all code must be tested and checked by humans to maintain the reliability of the package. Confidential information should never be commited. + +> [!WARNING] +> Working with RDBES data is working with confidential data that is subjected to a data policy that aims to prevent unintended misuse or leakage of information by individual users, and keep trust in the RDBES system. Because of that, RDBES data should be handled with special care (e.g., never be commited to github or AI services without explicit permission from the data owner) and development should be done, to the extent possible, using synthetic or public data. + +### 1. Getting started + +Install a recent version of R (4.1 or newer), preferably with RStudio, and the packages `remotes`, `devtools`, `roxygen2` and `testthat`. + +Use **camelCase** for new function names to match the existing package style. See the package style guide for more details [style guide](https://github.com/ices-tools-dev/RDBEScore/blob/main/WGRDBES-EST/newbies_guide/StyleGuide_WKRDB-EST_Annex8.pdf). Two useful examples are [createRDBESDataObject](https://github.com/ices-tools-dev/RDBEScore/blob/dev/R/createRDBESDataObject.R) and the simpler [getTablesInRDBESHierarchy](https://github.com/ices-tools-dev/RDBEScore/blob/dev/R/getTablesInRDBESHierarchy.R). + +The main package directories are: + +- `R/` — R functions +- `tests/testthat/` — function tests +- `data/` — packaged datasets +- `data-raw/` — scripts preparing package data +- `vignettes/` — examples and user guides +- `WGRDBES-EST/` — additional documentation + +### 2. Development workflow + +1. **Create or claim a GitHub issue.** Describe what needs to be added or changed, including the expected behaviour. Assign yourself to the issue when you start working on it so others know. + +2. **Start from the latest `dev` branch.** Work directly on `dev` if you can ensure that you never commit code that has failing tests. If you are unsure you can always create your own development branch based on `dev` and work there. Wherever you work remember to pull frequently so your code does not deviate too far from others. The `main` branch is protected and only accepts changes through pull requests. + +3. **Write or modify the code and tests.** You can do this manually or with AI coding tools. New functions should include *roxygen2* documentation and appropriate tests. Add or update examples and vignettes when relevant. Aim to keep changes related to one issue together. + +4. **Document AI involvement and human review.** Add the information described in Section 3 to every new or substantially modified function and test(s). + +5. **Check the complete package** before integrating changes into `dev`. Regenerate documentation, run the tests and check the package: + + ```r + devtools::document() + devtools::test() + devtools::check() + ``` + + Fix any problems introduced by your changes before submitting them. + +6. **Commit your changes**, including the issue number in the commit message, for example: `Improve data validation #123` GitHub automatically links the commit to the issue, preserving the development history. Keep unrelated changes in separate commits whenever possible. + +7. **Request additional review if needed.** Ask another contributor in the issue discussion or add the `human review required` label. Once the changes are ready, they can be incorporated into `dev`. Only changes considered ready for release should be transferred to `main`. + +### 3. AI-assisted development and human review + +Starting with version 0.3.5, contributors are permitted to use AI coding tools to accelerate development. However, all contributors remain responsible for understanding and verifying their code, regardless of whether it was written manually or generated with AI. If you possess confidential RDBES data when using installed AI products (e.g. VScode, Codex, Claude Code, PositAI, browser add-ons etc), that is only allowed if you have explicit permission from the data owner. Browser-based AI may also be used as long as tools permissions have been checked and confidential information or data is not submitted to them. + +Every **new or substantially modified** function and test must document **AI involvement**. + +**Function documentation** + +Include a `Development review` section in the function's *roxygen2* documentation so that the information appears in the installed package's R help pages (`?functionName`). + +```r +#' @section Development review: +#' - AI-assisted: Yes +#' - Review: janesmith +#' - Notes/scope: Tested with hierarchy H5 using +#' 2025 RDBES data (downloaded 2026-10-14). +``` +Notes should be added if no formal testing was made (e.g. downloading confidential data and checking how a function works on this data without writing tests). + +**Test documentation** + +We expect that all tests are human reviewed. Add the same information as comments immediately in the beginning of a test file as you do with code. + ```r -function zeroIds(sl) { +# AI-assisted: Yes +# Review: janesmith +# Notes/scope: Tested with hierarchy H5 using +# 2025 RDBES data (downloaded 2026-10-14). +capture.output({ ## suppresses printing of console output when running test() + test_that("function returns correct values", { + expect_equal(myFunction(2), 4) + }) + + test_that("function handles missing values", { + expect_true(is.na(myFunction(NA))) + }) +}) +``` + +**Meaning of the fields** + +- **AI-assisted:** `Yes` if AI tools were used to generate or substantially modify the current code or test, otherwise `No`. Routine autocomplete or minor wording corrections do not need to be reported. +- **Review:** GitHub usernames of people who have checked and accepted the current implementation or test. The original contributor records one approval after checking their own work. Each additional reviewer who approves the current version is added. +- **Notes/scope (optional):** Briefly describe what has been verified, for example specific RDBES sampling hierarchies, datasets, reference calculations, or known limitations. Include data versions or dates when relevant. + +**Updating review** + +When another person reviews the code or test and approves it without changes, add their username: + +```r +# Review: janesmith, johnbrown +``` + +If a reviewer wants to modify the code substantially, they are expected to raise an issue to inform others about it. Previous reviewers should be assigned to that issue and informed about the new issue. + +Review for functions and tests are maintained separately. A change to one does not automatically invalidate approval of the other, unless its correctness is affected. + +**Major changes** +Major changes (Sensu changes to multiple functions, that take time to review) should only be done after a plenary discussion. To the extent possible, the previous reviewers are informed ahead of those changes and allowed enough time to form an opinion. + +**Testing and scientific reliability** + +All new or modified functionality should have appropriate tests. Expected test results must be independently established or checked rather than relying solely on AI-generated expectations. Where possible, statistical estimation functions should be tested against manually calculated results, published examples or independently verified reference implementations. + +Additional independent human review is particularly encouraged for statistical estimation functions and scientifically important data transformations. The number of human review indicates the extent of documented human review, but does not by itself guarantee scientific correctness. The optional `Notes/scope` field can clarify what has actually been verified. + +Existing functions and tests do not need to be retrospectively classified unless they are modified. + +### 4. Releasing reviewed changes to `main` + +The `dev` branch may contain functions that are still being developed, tested or reviewed. **Only changes considered ready for release should be transferred to `main`.** + +We aim at 2 releases a year (autumn and spring) and an online meeting will be scheduled to approve the pull request to the main. + +When preparing a release, a subset of the package contributors will: + +1. Identify the functions and changes that are ready, considering their tests, human review and any review notes. +2. If only some changes from `dev` are ready, create a release branch from `main` and selectively transfer the required commits using Git cherry-pick. Include any dependent changes, tests and documentation. +3. Run `devtools::document()`, `devtools::test()` and `devtools::check()` on the complete release candidate. +4. Submit a pull request to `main` for final review and merging. + + +Changes that are not yet sufficiently reviewed remain in `dev`. The complete `dev` branch should only be merged into `main` when all included changes are ready for release. + +Keeping commits focused on individual issues or functions makes selective releases easier. + +### 5. On `data.table` usage + +Objects of type `data.table` passed as parameters should be copied before modification to avoid unintentionally changing the original object by reference. + +For example: + +```r +zeroIds <- function(sl) { sl <- data.table::copy(sl) - sl[,SLid:=0] + sl[, SLid := 0] sl } ``` -Now invocations of this function on SL tables will not alter the original copy. -## Precommit-hook framework +This ensures that calling `zeroIds()` does not modify the original input table. -For adhering to package styling guides it is advisable to use precommit checks while developing. -In order to run lintr and styler (etc) before committing code, follow the instructions at the following address: https://github.com/lorenzwalthert/precommit#installation +### 6. Building binary packages (optional) -1. Check that python3 is installed and install if necessary -2. Run pip install - ```bash - pip3 install pre-commit --user - ``` -3. Install R precommit package - ```r - install.packages("precommit") - ``` -4. Run at the root of the git repository. - ```r - library(precommit) - precommit::use_precommit() - ``` -5. Running git commit should run the various checks automatically. See [the config file](.pre-commit-config.yaml) for all the checks. +Binary packages can be built in RStudio using **Build → More → Build Binary Package**. -## Building binary packages +Alternatively, use the command line: -Building binary packages can be achieved by running the following commands. ```bash -Rscript.exe -e "roxygen2::roxygenize('.', roclets = c('rd', 'collate', 'namespace'))" -Rcmd.exe INSTALL --build --preclean . +Rscript -e "roxygen2::roxygenize('.', roclets = c('rd', 'collate', 'namespace'))" +R CMD INSTALL --build . ``` -Note to replace `.` with the relative path of the project if necessary. Also on some operating systems, `Rcmd.exe` is called `Rcmd` and `Rscript.exe` is `Rcmd` respectively. -In R-studio there is also a button on the `build` - tab: `More -> Build Binary Package` that builds the binary package. +Commands and executable names may vary slightly between operating systems. Building binary packages is not required for normal development. diff --git a/WGRDBES-EST/presentations/WGRDBES-EST_Poster_2026.pptx b/WGRDBES-EST/presentations/WGRDBES-EST_Poster_2026.pptx new file mode 100644 index 00000000..cf27cb46 Binary files /dev/null and b/WGRDBES-EST/presentations/WGRDBES-EST_Poster_2026.pptx differ diff --git a/WGRDBES-EST/presentations/package_overview_11-03-2026.pptx b/WGRDBES-EST/presentations/package_overview_11-03-2026.pptx new file mode 100644 index 00000000..22a091ea Binary files /dev/null and b/WGRDBES-EST/presentations/package_overview_11-03-2026.pptx differ diff --git a/data-raw/add2PackageDataWGRDBES-EST_TEST_1.R b/data-raw/add2PackageDataWGRDBES-EST_TEST_1.R index ef0b4dec..7833e30d 100644 --- a/data-raw/add2PackageDataWGRDBES-EST_TEST_1.R +++ b/data-raw/add2PackageDataWGRDBES-EST_TEST_1.R @@ -1,6 +1,6 @@ #read the downloaded zip file #this file is downloaded from the RDBES the contents of this file is prepared in -# the files in the directory exampleData/TextBookExamples and uploaded to RDBES +#the files in the directory exampleData/TextBookExamples and uploaded to RDBES zipFname <- "./data-raw/exampleData/TextBookExamples/DownloadsFromRDBES/ZW_1965_WGRDBES-EST_TEST_1.zip" data <- RDBEScore::createRDBESDataObject(zipFname) @@ -11,26 +11,34 @@ data <- RDBEScore::filterRDBESDataObject(data, fieldsToFilter = "DEsampScheme", valuesToFilter = samp_scheme, killOrphans = T) + +# dataset Pckg_SDAResources_coots_multistage_H1 has NA as VSnumTotal which +# creates a warning message when data is printed,. The following code +# checks that dataset is the only case, otherwise stops +aux<-RDBEScore:::createTableOfRDBESIds(data) +VSid_without_VSnumTotal<-unique( + aux[aux$DEid==data$DE$DEid[ + data$DE$DEstratumName=="Pckg_SDAResources_coots_multistage_H1"],"VSid"]) +if(!nrow(data$VS[is.na(data$VS$VSnumTotal)])==length(VSid_without_VSnumTotal)){ + stop() +} + datasetNames <- unique(data$DE$DEstratumName) -#fix wrong named data these are from survey actually -wrongDataSets <- c('Pckg_SDAResources_apiclus1_v2_H1', - 'Pckg_SDAResources_apiclus2_v2_H1') #add all stratums to package data for(dname in datasetNames){ #fix the naming removing strange characters datasetName <- gsub("[[:punct:]]|[[:space:]]", "_", paste0(dname)) - #replace the name - if(dname %in% wrongDataSets){ - datasetName <- sub("SDAResources", "survey", datasetName) - } deData <- RDBEScore::filterRDBESDataObject(data, - fieldsToFilter = "DEstratumName", - valuesToFilter = dname, + fieldsToFilter = c("DEstratumName","SLspeclistName"), + valuesToFilter = c(dname,paste0("WGRDBES-EST_TEST_1_",datasetName)), killOrphans = T) + # the following should be deleted when #253 issue solved + deData$IS<-deData$IS[SLid %in% deData$SL$SLid,] + # restricts species list - deData$SL<-deData$SL[grepl(deData$SL$SLspeclistName, pat=dname)] + #deData$SL<-deData$SL[grepl(deData$SL$SLspeclistName, pat=dname)] assign(datasetName, deData) do.call(eval(parse(text="usethis::use_data")), diff --git a/data-raw/exampleData/TextBookExamples/BuildTextBookDataUpload_All.R b/data-raw/exampleData/TextBookExamples/BuildTextBookDataUpload_All.R index b9e98c61..df429b70 100644 --- a/data-raw/exampleData/TextBookExamples/BuildTextBookDataUpload_All.R +++ b/data-raw/exampleData/TextBookExamples/BuildTextBookDataUpload_All.R @@ -5,7 +5,7 @@ source("BuildTextBookDataUpload_Pckg_SDAResources_coots_H1.R") source("BuildTextBookDataUpload_Pckg_SDAResources_coots_multistage_H1.R") source("BuildTextBookDataUpload_Pckg_SDAResources_gpa_H1.R") source("BuildTextBookDataUpload_Pckg_SDAResources_schools_H1.R") -source("BuildTextBookDataUpload_Pckg_survey_apiclus1_v2_H1.R") +source("BuildTextBookDataUpload_Pckg_survey_apiclus1_H1.R") source("BuildTextBookDataUpload_Pckg_survey_apiclus2_H1.R") source("BuildTextBookDataUpload_Pckg_survey_apiclus2_v2_H1.R") source("BuildTextBookDataUpload_Pckg_survey_apistrat_H1.R") diff --git a/data-raw/exampleData/TextBookExamples/BuildTextBookDataUpload_Pckg_survey_apiclus1_v2_H1.R b/data-raw/exampleData/TextBookExamples/BuildTextBookDataUpload_Pckg_survey_apiclus1_H1.R similarity index 99% rename from data-raw/exampleData/TextBookExamples/BuildTextBookDataUpload_Pckg_survey_apiclus1_v2_H1.R rename to data-raw/exampleData/TextBookExamples/BuildTextBookDataUpload_Pckg_survey_apiclus1_H1.R index 03fbeb0a..55b3eeb6 100644 --- a/data-raw/exampleData/TextBookExamples/BuildTextBookDataUpload_Pckg_survey_apiclus1_v2_H1.R +++ b/data-raw/exampleData/TextBookExamples/BuildTextBookDataUpload_Pckg_survey_apiclus1_H1.R @@ -38,13 +38,13 @@ target_var<-"enroll" # name your project (will be used in filenames for CS, SL and VD) - project_name_outputs <- "WGRDBES-EST_TEST_1_Pckg_survey_apiclus1_v2_H1" + project_name_outputs <- "WGRDBES-EST_TEST_1_Pckg_survey_apiclus1_H1" # select a year for upload DEyear<-1965 SDinstitution <- 4484 - DEsamplingScheme<-"WGRDBES-EST TEST 1" - DEstratumName <- "Pckg_SDAResources_apiclus1_v2_H1" + DEsamplingScheme <- "WGRDBES-EST TEST 1" + DEstratumName <- "Pckg_survey_apiclus1_H1" project_name_outputs <- gsub(" ","_", paste0(DEsamplingScheme,"_", DEstratumName)) baseDir <- "./data-raw/exampleData/TextBookExamples/" baseDir <- "" diff --git a/data-raw/exampleData/TextBookExamples/DownloadsFromRDBES/ZW_1965_WGRDBES-EST_TEST_1.zip b/data-raw/exampleData/TextBookExamples/DownloadsFromRDBES/ZW_1965_WGRDBES-EST_TEST_1.zip index 177ee14e..9534d10f 100644 Binary files a/data-raw/exampleData/TextBookExamples/DownloadsFromRDBES/ZW_1965_WGRDBES-EST_TEST_1.zip and b/data-raw/exampleData/TextBookExamples/DownloadsFromRDBES/ZW_1965_WGRDBES-EST_TEST_1.zip differ diff --git a/data/Pckg_SDAResources_agsrs_H1.rda b/data/Pckg_SDAResources_agsrs_H1.rda new file mode 100644 index 00000000..02f662c0 Binary files /dev/null and b/data/Pckg_SDAResources_agsrs_H1.rda differ diff --git a/data/Pckg_SDAResources_agstrat_H1.rda b/data/Pckg_SDAResources_agstrat_H1.rda index 09d22092..06c5d8fc 100644 Binary files a/data/Pckg_SDAResources_agstrat_H1.rda and b/data/Pckg_SDAResources_agstrat_H1.rda differ diff --git a/data/Pckg_SDAResources_algebra_H1.rda b/data/Pckg_SDAResources_algebra_H1.rda new file mode 100644 index 00000000..5d6e6040 Binary files /dev/null and b/data/Pckg_SDAResources_algebra_H1.rda differ diff --git a/data/Pckg_SDAResources_coots_H1.rda b/data/Pckg_SDAResources_coots_H1.rda new file mode 100644 index 00000000..d1b47cc9 Binary files /dev/null and b/data/Pckg_SDAResources_coots_H1.rda differ diff --git a/data/Pckg_SDAResources_coots_multistage_H1.rda b/data/Pckg_SDAResources_coots_multistage_H1.rda new file mode 100644 index 00000000..37632c5b Binary files /dev/null and b/data/Pckg_SDAResources_coots_multistage_H1.rda differ diff --git a/data/Pckg_SDAResources_gpa_H1.rda b/data/Pckg_SDAResources_gpa_H1.rda new file mode 100644 index 00000000..da727145 Binary files /dev/null and b/data/Pckg_SDAResources_gpa_H1.rda differ diff --git a/data/Pckg_SDAResources_schools_H1.rda b/data/Pckg_SDAResources_schools_H1.rda new file mode 100644 index 00000000..ae0d0b3f Binary files /dev/null and b/data/Pckg_SDAResources_schools_H1.rda differ diff --git a/data/Pckg_survey_apiclus1_H1.rda b/data/Pckg_survey_apiclus1_H1.rda new file mode 100644 index 00000000..dfc113ea Binary files /dev/null and b/data/Pckg_survey_apiclus1_H1.rda differ diff --git a/data/Pckg_survey_apiclus2_H1.rda b/data/Pckg_survey_apiclus2_H1.rda index 7a926e12..95d31c0f 100644 Binary files a/data/Pckg_survey_apiclus2_H1.rda and b/data/Pckg_survey_apiclus2_H1.rda differ diff --git a/data/Pckg_survey_apiclus2_v2_H1.rda b/data/Pckg_survey_apiclus2_v2_H1.rda new file mode 100644 index 00000000..55f44fb9 Binary files /dev/null and b/data/Pckg_survey_apiclus2_v2_H1.rda differ diff --git a/data/Pckg_survey_apistrat_H1.rda b/data/Pckg_survey_apistrat_H1.rda index 094c5a85..7d89fe98 100644 Binary files a/data/Pckg_survey_apistrat_H1.rda and b/data/Pckg_survey_apistrat_H1.rda differ diff --git a/man/H7Example.Rd b/man/H7Example.Rd index f2aecf75..2c81397c 100644 --- a/man/H7Example.Rd +++ b/man/H7Example.Rd @@ -17,7 +17,9 @@ A list containing entries required for H7 RDBES data: \item{SL}{the Species List data table} \item{IS}{the Individual Species table} } -#' @source Richard Meitern @ Estonian Marine Institute, 2025 +} +\source{ +Richard Meitern @ Estonian Marine Institute, 2025 } \usage{ H7Example diff --git a/man/H8ExampleEE1.Rd b/man/H8ExampleEE1.Rd index 3e2fa96a..dd2ef813 100644 --- a/man/H8ExampleEE1.Rd +++ b/man/H8ExampleEE1.Rd @@ -21,7 +21,9 @@ A list containing entries required for H8 RDBES data: \item{CL}{the Commertial Landing data table} \item{CE}{the Commertial Effort data table} } -#' @source Richard Meitern @ Estonian Marine Institute, 2025 +} +\source{ +Richard Meitern @ Estonian Marine Institute, 2025 } \usage{ H8ExampleEE1 diff --git a/man/Pckg_SDAResources_agsrs_H1.Rd b/man/Pckg_SDAResources_agsrs_H1.Rd new file mode 100644 index 00000000..8864fecc --- /dev/null +++ b/man/Pckg_SDAResources_agsrs_H1.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{Pckg_SDAResources_agsrs_H1} +\alias{Pckg_SDAResources_agsrs_H1} +\title{A RDBESDataObject converted from package SDAResources dataset agsrs} +\format{ +A list containing entries required for H1 RDBES data: +\describe{ +\item{DE}{the Design data table. Contains dummy values with exception of +Design-Variables in VS that match the book} +\item{SD}{the Sampling Details data table. Contains dummy values} +\item{VS}{the Vessel Selection data table. Contains core information of +data(agsrs), VSnumberSampled and VSnumberTotal set according to agsrs +and book pop values, VSunitName is set to a combination of original +agsrs$county, agsrs$state, agsrs$region and row numbers} +\item{FT}{the Fishing Trip data table. Contains dummy values} +\item{FO}{the Fishing Operation data table. Contains dummy values} +\item{SS}{the Species Selection data table. Contains dummy values} +\item{SA}{the Sample data table. Contains the variable measured +agsrs$acres92 in SAtotalWeightMeasured, SAsampleWeightMeasured and +SAconversionFactorMeasLive set to 1, and the domain information, +coded in SAarea} +\item{FM}{the Frequency Measure data table. Not provided} +\item{BV}{the Biological Variable data table. Not provided} +\item{VD}{the Vessel Details data table. Subset to the essential rows} +\item{SL}{the Species List data table. Subset to the essential rows} +\item{IS}{the Individual Species table} +} +} +\source{ +\url{https://CRAN.R-project.org/package=SDAResources} +} +\usage{ +Pckg_SDAResources_agsrs_H1 +} +\description{ +This data set is derived from the data(agsrs) used in Lohr examples 2.6, 2.7 +and 2.11 of SDA book. Information required for example 4.8 +(domain estimation) is also added to SA (farmcat <=> SAarea). +VSnumberSampled and VSnumberTotal set according to agsrs and book pop +values. VSunitName is set to a combination of original agsrs$county, +agsrs$state, agsrs$region and row numbers. Table SA contains the variable +measured agsrs$acres92 in SAtotalWeightMeasured, SAsampleWeightMeasured and +SAconversionFactorMeasLive set to 1. Table SA also contains the domain +information, coded in SAarea. Table DE, SD, FT and FO are for the most +dummy tables inserted to meet RDBES model requirements to be aggregated +during estimation tests. Values of mandatory fields have dummy values with +exception of Design-Variables in VS that match the book. BV, FM, CL, and CE +are not provided. SL and VD are subset to the essential rows. +} +\keyword{datasets} diff --git a/man/Pckg_SDAResources_algebra_H1.Rd b/man/Pckg_SDAResources_algebra_H1.Rd new file mode 100644 index 00000000..fe13549b --- /dev/null +++ b/man/Pckg_SDAResources_algebra_H1.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{Pckg_SDAResources_algebra_H1} +\alias{Pckg_SDAResources_algebra_H1} +\title{A RDBESDataObject converted from package SDAResources dataset algebra} +\format{ +A list containing entries required for H1 RDBES data: +\describe{ +\item{DE}{the Design data table. Contains 1 DE row with +DEstratumName == "Pckg_SDAResources_algebra_H1"} +\item{SD}{the Sampling Details data table. Contains 1 child SD row} +\item{VS}{the Vessel Selection data table. Contains 299 child rows +(the 299 students observed), each associated to its cluster (class), +VSnumberTotalClusters is 187, VSnumberSampledClusters is 12, +VSnumberTotal is Missing} +\item{FT}{the Fishing Trip data table. Just 1:1 links to the final +data (in SA)} +\item{FO}{the Fishing Operation data table. Just 1:1 links to the final +data (in SA)} +\item{SS}{the Species Selection data table. Just 1:1 links to the final +data (in SA)} +\item{SA}{the Sample data table. Each score is a SAsampleWeightMeasured} +\item{FM}{the Frequency Measure data table} +\item{BV}{the Biological Variable data table} +\item{VD}{the Vessel Details data table} +\item{SL}{the Species List data table} +\item{IS}{the Individual Species table} +} +} +\source{ +\url{https://CRAN.R-project.org/package=SDAResources} +} +\usage{ +Pckg_SDAResources_algebra_H1 +} +\description{ +This data set is derived from a fictional data for an SRS of 12 algebra +classes in a city, from a population of 187 classes. The design is 1-stage +cluster sampling with clusters of unequal sizes. Clusters are classes (class). +Clusters (psu) are unequal sized (Mi). In each cluster, all students are +selected (ssus, nrows). The total number of psus is known (187). The target +variable is score. +} +\keyword{datasets} diff --git a/man/Pckg_SDAResources_coots_H1.Rd b/man/Pckg_SDAResources_coots_H1.Rd new file mode 100644 index 00000000..0769705e --- /dev/null +++ b/man/Pckg_SDAResources_coots_H1.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{Pckg_SDAResources_coots_H1} +\alias{Pckg_SDAResources_coots_H1} +\title{A RDBESDataObject converted from package SDAResources dataset coots} +\format{ +A list containing entries required for H1 RDBES data: +\describe{ +\item{DE}{the Design data table. Contains 1 DE row with +DEstratumName == "Pckg_SDAResources_coots_H1"} +\item{SD}{the Sampling Details data table. Contains 1 child SD row} +\item{VS}{the Vessel Selection data table. Contains 368 child rows +(the 368 eggs/psus observed), each associated to its cluster (clutch), +VSnumberTotalClusters is not known, VSnumberTotal is csize} +\item{FT}{the Fishing Trip data table. Just 1:1 links to the final data +(in SA)} +\item{FO}{the Fishing Operation data table. Just 1:1 links to the final +data (in SA)} +\item{SS}{the Species Selection data table. Just 1:1 links to the +final data (in SA)} +\item{SA}{the Sample data table. Each volume is a SAsampleWeightMeasured. +ATT volumes are *100000000 to meet type requirement (integer)} +\item{FM}{the Frequency Measure data table} +\item{BV}{the Biological Variable data table} +\item{VD}{the Vessel Details data table} +\item{SL}{the Species List data table} +\item{IS}{the Individual Species table} +} +} +\source{ +\url{https://CRAN.R-project.org/package=SDAResources} +} +\usage{ +Pckg_SDAResources_coots_H1 +} +\description{ +This data set is derived from the data(coots). The design is 2-stage cluster +sampling with clusters of unequal sizes and Npsu not known. Clusters are +clutches of eggs (nests) with at least 2 eggs. In each cluster, the volume +of two eggs is measured. Clusters (psu) are unequal sized. In each cluster, +2 eggs are selected (ssus) and measured. The total number of psus is not +known (a drawback in this example). It is assumed very large (fpc negligible). +The target variable is volume (others are available). +} +\keyword{datasets} diff --git a/man/Pckg_SDAResources_coots_multistage_H1.Rd b/man/Pckg_SDAResources_coots_multistage_H1.Rd new file mode 100644 index 00000000..002d9fa1 --- /dev/null +++ b/man/Pckg_SDAResources_coots_multistage_H1.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{Pckg_SDAResources_coots_multistage_H1} +\alias{Pckg_SDAResources_coots_multistage_H1} +\title{A Multi-stage RDBESDataObject from package SDAResources dataset coots} +\format{ +A list containing entries required for H1 RDBES data: +\describe{ +\item{DE}{the Design data table. Contains 1 DE row with +DEstratumName == "Pckg_SDAResources_coots_H1"} +\item{SD}{the Sampling Details data table. Contains 1 child SD row} +\item{VS}{the Vessel Selection data table. Contains 184 child rows +(the 184 clutches/psus observed), each associated to its cluster (clutch), +VSnumberTotal is not known, VSnumberSampled is 184} +\item{FT}{the Fishing Trip data table. Contains 368 child rows +(the 368 eggs/ssus measured), each associated to its vessel (clutch), +FTnumbersampled is 2, FTnumberTotal is csize} +\item{FO}{the Fishing Operation data table. Just 1:1 links to the final +data (in SA)} +\item{SS}{the Species Selection data table. Just 1:1 links to the final +data (in SA)} +\item{SA}{the Sample data table. Each volume is a SAsampleWeightMeasured. +ATT volumes are *100000000 to meet type requirement (integer)} +\item{FM}{the Frequency Measure data table} +\item{BV}{the Biological Variable data table} +\item{VD}{the Vessel Details data table} +\item{SL}{the Species List data table} +\item{IS}{the Individual Species table} +} +} +\source{ +\url{https://CRAN.R-project.org/package=SDAResources} +} +\usage{ +Pckg_SDAResources_coots_multistage_H1 +} +\description{ +This data set is derived from the data(coots). The design is 2-stage cluster +sampling with clusters of unequal sizes and Npsu not known. Clusters are +clutches of eggs (nests) with at least 2 eggs. In each cluster, the volume +of two eggs is measured. Clusters (psu) are unequal sized. In each cluster, +2 eggs are selected (ssus) and measured. The total number of psus is not +known (a drawback in this example). It is assumed very large (fpc negligible). +The target variable is volume. +} +\keyword{datasets} diff --git a/man/Pckg_SDAResources_gpa_H1.Rd b/man/Pckg_SDAResources_gpa_H1.Rd new file mode 100644 index 00000000..66780da1 --- /dev/null +++ b/man/Pckg_SDAResources_gpa_H1.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{Pckg_SDAResources_gpa_H1} +\alias{Pckg_SDAResources_gpa_H1} +\title{A RDBESDataObject converted from package SDAResources dataset gpa} +\format{ +A list containing entries required for H1 RDBES data: +\describe{ +\item{DE}{the Design data table. Contains 1 DE row with +DEstratumName == "Pckg_SDAResources_gpa_H1"} +\item{SD}{the Sampling Details data table. Contains 1 child SD row} +\item{VS}{the Vessel Selection data table. Contains 20 child rows +(the 20 observations), each associated to its cluster (suite), +VSnumberTotalClusters is 100, VSnumberTotal is 4 because all elements in +cluster are sampled} +\item{FT}{the Fishing Trip data table. Just 1:1 links to the final data +(in SA)} +\item{FO}{the Fishing Operation data table. Just 1:1 links to the final +data (in SA)} +\item{SS}{the Species Selection data table. Just 1:1 links to the final +data (in SA)} +\item{SA}{the Sample data table. Each gpa score is a +SAsampleWeightMeasured. ATT gpa scores are *100 to meet type requirement +(integer)} +\item{FM}{the Frequency Measure data table} +\item{BV}{the Biological Variable data table} +\item{VD}{the Vessel Details data table} +\item{SL}{the Species List data table} +\item{IS}{the Individual Species table} +} +} +\source{ +\url{https://CRAN.R-project.org/package=SDAResources} +} +\usage{ +Pckg_SDAResources_gpa_H1 +} +\description{ +This data set is derived from the data(gpa). The design is 1-stage cluster +sampling with clusters of equal sizes. Each cluster (suite) has 4 elements +with the same weight. The target variable is gpa. +} +\keyword{datasets} diff --git a/man/Pckg_SDAResources_schools_H1.Rd b/man/Pckg_SDAResources_schools_H1.Rd new file mode 100644 index 00000000..14e205d7 --- /dev/null +++ b/man/Pckg_SDAResources_schools_H1.Rd @@ -0,0 +1,43 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{Pckg_SDAResources_schools_H1} +\alias{Pckg_SDAResources_schools_H1} +\title{A RDBESDataObject converted from package SDAResources dataset schools} +\format{ +A list containing entries required for H1 RDBES data: +\describe{ +\item{DE}{the Design data table. Contains 1 DE row with +DEstratumName == "Pckg_SDAResources_schools_H1"} +\item{SD}{the Sampling Details data table. Contains 1 child SD row} +\item{VS}{the Vessel Selection data table. Contains 200 child rows +(the 200 students observed), each associated to its cluster (schoolid), +VSnumberTotalClusters is 100, VSnumberTotal is Mi} +\item{FT}{the Fishing Trip data table. Just 1:1 links to the final data +(in SA)} +\item{FO}{the Fishing Operation data table. Just 1:1 links to the +final data (in SA)} +\item{SS}{the Species Selection data table. Just 1:1 links to the +final data (in SA)} +\item{SA}{the Sample data table. Each volume is a SAsampleWeightMeasured} +\item{FM}{the Frequency Measure data table} +\item{BV}{the Biological Variable data table} +\item{VD}{the Vessel Details data table} +\item{SL}{the Species List data table} +\item{IS}{the Individual Species table} +} +} +\source{ +\url{https://CRAN.R-project.org/package=SDAResources} +} +\usage{ +Pckg_SDAResources_schools_H1 +} +\description{ +This data set is derived from the data(schools). The design is 2-stage cluster +sampling with clusters of unequal sizes and Npsu not known. Clusters are +schools (schoolid). Clusters (psu) are unequal sized (Mi). In each cluster, +20 students are selected (ssus) and measured (nrows). The total number of +psus is known (75). The target variable is mathlevel. +} +\keyword{datasets} diff --git a/man/Pckg_survey_apiclus1_H1.Rd b/man/Pckg_survey_apiclus1_H1.Rd new file mode 100644 index 00000000..0d6cd8c1 --- /dev/null +++ b/man/Pckg_survey_apiclus1_H1.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{Pckg_survey_apiclus1_H1} +\alias{Pckg_survey_apiclus1_H1} +\title{A RDBESDataObject converted from package survey dataset apiclus1} +\format{ +A list containing entries required for H1 RDBES data: +\describe{ +\item{DE}{the Design data table. Contains 1 DE row with DEstratumName == "Pckg_SDAResources_apiclus1_v2_H1"} +\item{SD}{the Sampling Details data table. Contains 1 child SD row} +\item{VS}{the Vessel Selection data table. Contains 183 child rows (the 186 schools finally observed), each associated to its cluster (dname), VSnumberTotalClusters is 757, VSnumberTotal is the number of schools in the cluster (census), calibrated weights are provided as 1/pw in VSinclusionProbCluster} +\item{FT}{the Fishing Trip data table. Just 1:1 links to the final data (in SA)} +\item{FO}{the Fishing Operation data table. Just 1:1 links to the final data (in SA)} +\item{SS}{the Species Selection data table. Just 1:1 links to the final data (in SA)} +\item{SA}{the Sample data table. SAsampleWeightMeasured is enroll} +\item{FM}{the Frequency Measure data table} +\item{BV}{the Biological Variable data table} +\item{VD}{the Vessel Details data table} +\item{SL}{the Species List data table} +\item{IS}{the Individual Species table} +} +} +\source{ +\url{https://CRAN.R-project.org/package=survey} +} +\usage{ +Pckg_survey_apiclus1_H1 +} +\description{ +This data set is derived from the Academic Performance Index computed for all +California schools based on standardized testing of students. The original +data sets contain information for all schools with at least 100 students and +for various probability samples of the data. The design is 1-stage cluster +sampling with clusters of unequal sizes. An SRS of 15 districts is selected +(psus) from the 757 districts in the population. All schools within district +are selected (ssus). The weights (pw) do not match 757/15 probably because +they have been calibrated. The target variable is enroll. +} +\keyword{datasets} diff --git a/man/Pckg_survey_apiclus2_v2_H1.Rd b/man/Pckg_survey_apiclus2_v2_H1.Rd new file mode 100644 index 00000000..fec07355 --- /dev/null +++ b/man/Pckg_survey_apiclus2_v2_H1.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/data.R +\docType{data} +\name{Pckg_survey_apiclus2_v2_H1} +\alias{Pckg_survey_apiclus2_v2_H1} +\title{A Clustered RDBESDataObject converted from package survey dataset apiclus2} +\format{ +A list containing entries required for H1 RDBES data: +\describe{ +\item{DE}{the Design data table. Contains 1 DE row with DEstratumName == "Pckg_SDAResources_apiclus2_v2_H1"} +\item{SD}{the Sampling Details data table. Contains 1 child SD row} +\item{VS}{the Vessel Selection data table. Contains 126 child rows (the 126 schools finally observed), each associated to its cluster (dname), VSnumberTotalClusters is 757, VSnumberTotal is 1...5 schools sampled} +\item{FT}{the Fishing Trip data table. Just 1:1 links to the final data (in SA)} +\item{FO}{the Fishing Operation data table. Just 1:1 links to the final data (in SA)} +\item{SS}{the Species Selection data table. Just 1:1 links to the final data (in SA)} +\item{SA}{the Sample data table. SAsampleWeightMeasured is enroll (note the 4 NAs)} +\item{FM}{the Frequency Measure data table} +\item{BV}{the Biological Variable data table} +\item{VD}{the Vessel Details data table} +\item{SL}{the Species List data table} +\item{IS}{the Individual Species table} +} +} +\source{ +\url{https://CRAN.R-project.org/package=survey} +} +\usage{ +Pckg_survey_apiclus2_v2_H1 +} +\description{ +This data set is derived from the Academic Performance Index computed for all +California schools based on standardized testing of students. The original +data sets contain information for all schools with at least 100 students and +for various probability samples of the data. The design is 2-stage cluster +sampling with clusters of unequal sizes. An SRS of 40 districts is selected +(psus) from the 757 districts in the population and then up to 5 schools (min +\enumerate{ +\item were selected from each district (ssus). The target variable is enroll - note that it contains 4 NA values. +} +} +\keyword{datasets} diff --git a/man/createRDBESEstObject.Rd b/man/createRDBESEstObject.Rd index c4d6672a..eec0b685 100644 --- a/man/createRDBESEstObject.Rd +++ b/man/createRDBESEstObject.Rd @@ -40,6 +40,14 @@ estimation \description{ Creates an RDBESEstObject from RDBES data } +\section{Development review}{ + +\itemize{ +\item AI-assisted: No +\item Human review: rix133 +} +} + \examples{ myH1EstObj <- createRDBESEstObject(H1Example, 1, "SA") } diff --git a/man/detectNonExportedExamples.Rd b/man/detectNonExportedExamples.Rd new file mode 100644 index 00000000..5a48099a --- /dev/null +++ b/man/detectNonExportedExamples.Rd @@ -0,0 +1,89 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/detectNonExportedExamples.R +\name{detectNonExportedExamples} +\alias{detectNonExportedExamples} +\title{Detect Non-Exported Functions Used in Package Examples} +\usage{ +detectNonExportedExamples(pkgPath) +} +\arguments{ +\item{pkgPath}{Character string specifying the path to the root directory +of an R package source tree. The directory should contain \file{man/}, +\file{R/}, and \file{NAMESPACE}.} +} +\value{ +A data frame with one row per detected call and the following +columns: +\describe{ +\item{topic}{Name of the Rd documentation topic in which the call +was detected, usually the filename without the \file{.Rd} extension.} +\item{function_name}{Name of the non-exported function detected in +the example.} +\item{call_type}{Type of call: \code{unqualified} for a direct +function call, or \code{explicit :::} for an explicitly +namespace-qualified call using the triple-colon operator.} +\item{defined_in_package}{Logical value indicating whether the +function was found among the function definitions detected in the +package's \file{R/} source files.} +} + +If no matching calls are found, an empty data frame with these columns +is returned. +} +\description{ +Scans the \file{man/} directory of an R package and identifies calls to +non-exported functions in the examples sections of its Rd documentation. +Function definitions are collected from the package's \file{R/} directory, +and exported function names are read from the package's +\file{NAMESPACE} file. +} +\details{ +The function does not execute examples. It parses the documentation and +source files to identify candidate calls to non-exported functions. + +The function identifies two types of calls: +\itemize{ +\item Unqualified calls to functions defined in the package source +that are not listed as exports in \file{NAMESPACE}. +\item Calls using \code{pkg:::fun()}, where \code{pkg} matches the +package directory name and \code{fun} is not exported. +} + +The \code{defined_in_package} column is based on static inspection of +source files. A value of \code{FALSE} for an explicitly qualified call +means that a matching direct function definition was not found. This +does not necessarily mean that the function is absent; it may be generated +dynamically or defined in a form not recognized by the detector. + +The analysis is static and may not identify calls created dynamically +through mechanisms such as \code{get()}, \code{assign()}, or +metaprogramming. It also relies on the package's source files and +\file{NAMESPACE} being consistent with the documentation being inspected. +} +\section{Development review}{ + +\itemize{ +\item AI-assisted: Yes +\item Review: +\item Notes/scope: not really reviewed, just worked when needed and could be useful +in the future +} +} + +\examples{ +\dontrun{ +# Scan a local package source directory +issues <- detectNonExportedExamples("path/to/package") + +# Display all detected calls +print(issues) + +# Inspect calls whose definitions were not found in the source +subset(issues, defined_in_package == FALSE) +} + +} +\seealso{ +\code{\link[tools:parse_Rd]{tools::parse_Rd()}}, \code{\link[tools:Rd2ex]{tools::Rd2ex()}} +} +\keyword{internal} diff --git a/man/doEstimationRatio.Rd b/man/doEstimationRatio.Rd index 215d75a3..6cd2367c 100644 --- a/man/doEstimationRatio.Rd +++ b/man/doEstimationRatio.Rd @@ -11,30 +11,64 @@ doEstimationRatio( classUnits = "mm", classBreaks = c(100, 300, 10), LWparam = NULL, - lowerAux = NULL, verbose = FALSE ) } \arguments{ -\item{RDBESDataObj}{A validated RDBESDataObject containing hierarchical sampling and biological data. Must include appropriate tables (e.g., CL, CE, SA, FM, or BV) depending on estimation requirements.} +\item{RDBESDataObj}{A validated RDBESDataObject containing hierarchical +sampling and biological data. Must include relevant tables (SA, FM, +and/or BV) depending on the lower hierarchy.} -\item{targetValue}{A character string specifying the type of composition to estimate. Options are "LengthComp" or "AgeComp".} +\item{targetValue}{A character string specifying the type of composition to +estimate. Options are \code{"LengthComp"} or \code{"AgeComp"}.} -\item{raiseVar}{The variable used to construct the ratio.} +\item{raiseVar}{The raising variable used to construct the ratio estimator. +Options are \code{"Weight"} (SAtotalWtMes / SAsampWtMes), +\code{"Count"} (SAnumTotal / SAnumSamp), or any other value which will +use \code{SAauxVarValue} directly as the raise factor.} -\item{classUnits}{Units of the class intervals for length or age, typically "mm" for millimeters or "cm" for centimeters. Used in defining class intervals.} +\item{classUnits}{Units of the length class intervals, e.g. \code{"mm"} or +\code{"cm"}. Used only for \code{targetValue = "LengthComp"}: in LH A +and B, checks consistency with FM data; in LH C, used to transform raw BV +lengths before class assignment. +Codes: \url{https://vocab.ices.dk/?ref=1608}} -\item{classBreaks}{A numeric vector of three values: minimum value, maximum value, and class width (e.g., c(100, 300, 10)). Defines the class intervals for grouping lengths or ages.} +\item{classBreaks}{A numeric vector of three values: +\code{c(min, max, width)}. Defines the length class intervals. Used only +for \code{targetValue = "LengthComp"}.} -\item{LWparam}{A numeric vector of length two specifying parameters (a, b) for the weight-length relationship (W = a * L^b). Used if no direct weights are available but lengths are provided.} +\item{LWparam}{A numeric vector of length two \code{c(a, b)} specifying the +weight-length relationship (W = a * L^b). Used in LH A and B when +individual weights are absent from BV but lengths are available.} -\item{lowerAux}{A numeric or character vector referencing a variable in the SA table used as an auxiliary variable for ratio estimation (e.g., sample weights, sub-sample expansion factors).} - -\item{verbose}{Logical; if TRUE, detailed messages are printed during processing.} +\item{verbose}{Logical; if \code{TRUE}, informational messages are printed +during processing.} } \value{ -A list or data.table containing the estimated numbers at length or age and associated mean values such as weight and length, depending on input and target type. +A \code{data.table} with estimated numbers at length or age and +associated mean values. Key output columns: +\itemize{ +\item \code{LengthClass} or \code{Age} — the grouping variable +\item \code{NumbersAtLength} or \code{NumbersAtAge} — raised estimates +\item \code{MeanWeightAtLength} or \code{BVMeanWeight} — mean weight +\item \code{MeanLengthAtAge} — mean length at age (AgeComp only) +\item \code{raiseFactor} — the SA-level raise factor applied +} } \description{ -The function is under development and does not work yet. +Estimate Numbers and Mean Values by Length or Age Class +} +\details{ +The three lower hierarchies differ in which tables are present: +\itemize{ +\item \strong{LH A}: \code{SA -> FM -> BV}. FM holds the length-frequency; +BV holds individual biological measurements for a subsample of +fish within each FM length class. Supports both LengthComp and AgeComp. +\item \strong{LH B}: \code{SA -> FM} only. FM holds the length-frequency; +no individual biological measurements (no BV). Supports +LengthComp only; AgeComp is not possible without BV. +\item \strong{LH C}: \code{SA -> BV} only. Individual biological +measurements link directly to SA; no FM length-frequency tally. +Supports both LengthComp and AgeComp. +} } diff --git a/man/extractHigherFields.Rd b/man/extractHigherFields.Rd new file mode 100644 index 00000000..725ad096 --- /dev/null +++ b/man/extractHigherFields.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{extractHigherFields} +\alias{extractHigherFields} +\title{extractHigherFields} +\usage{ +extractHigherFields(object, table, field) +} +\arguments{ +\item{object}{An RDBESDataObject.} + +\item{table}{The table from which to start and go up the hierarchy +(e.g. \code{"SS"}).} + +\item{field}{The data (column name) to extract from any other table higher +in the hierarchy, e.g. \code{"DEyear"} or \code{"SDctry"}.} +} +\value{ +One value per row of \code{table}, in the same order. Rows that are not +linked to the table holding \code{field} get \code{NA} (e.g. orphans left by +filtering DE before \code{findAndKillOrphans()} runs in +\code{filterAndTidyRDBESDataObject()}). +} +\description{ +Gets data from higher in the hierarchy for the given input \code{table}. Only SS +explicitly supported for now, but could update in the future to support any +table (in theory). +} +\details{ +At present will not work with data which contains more than one hierarchy. +Also bypasses any optional tables (e.g. FT in H5). +} +\section{Development review}{ + +\itemize{ +\item AI-assisted: Yes +\item Human review: rix133 +} +} + +\examples{ +\dontrun{ + RDBEScore:::extractHigherFields(H1Example, "SS", "DEyear") +} +} +\keyword{internal} diff --git a/man/filterRDBESEstObject.Rd b/man/filterRDBESEstObject.Rd index 034dc96b..fcd9fc31 100644 --- a/man/filterRDBESEstObject.Rd +++ b/man/filterRDBESEstObject.Rd @@ -29,6 +29,14 @@ the filtered input object of the same class as The returned object will include all rows which include the field names and have one of the allowed values in \code{valuesToFilter}. } +\section{Development review}{ + +\itemize{ +\item AI-assisted: No +\item Human review: rix133 +} +} + \examples{ \dontrun{ diff --git a/man/findAndKillOrphans.Rd b/man/findAndKillOrphans.Rd index f92f8fe8..84520527 100644 --- a/man/findAndKillOrphans.Rd +++ b/man/findAndKillOrphans.Rd @@ -2,10 +2,7 @@ % Please edit documentation in R/findAndKillOrphans.R \name{findAndKillOrphans} \alias{findAndKillOrphans} -\title{This function finds and removed any orphan records in an -RDBESDataObject. Normally data that has been downloaded from the RDBES -will not contain orphan records - however if the data is subsequently -filtered it is possible to introduce orphan records.} +\title{Find and kill orphans in an RDBESDataObject} \usage{ findAndKillOrphans(objectToCheck, verbose = FALSE, strict = TRUE) } @@ -26,6 +23,8 @@ This function finds and removed any orphan records in an RDBESDataObject. Normally data that has been downloaded from the RDBES will not contain orphan records - however if the data is subsequently filtered it is possible to introduce orphan records. +The direction of the cleanup is effectively downstream. +The function does not remove parent rows because a child disappeared. } \examples{ \dontrun{ diff --git a/man/findOrphansByTable.Rd b/man/findOrphansByTable.Rd index 0019b62e..eea37edc 100644 --- a/man/findOrphansByTable.Rd +++ b/man/findOrphansByTable.Rd @@ -25,3 +25,11 @@ letter table identifier, and their orphan status. Internal function to identify orphan records in a given RDBESDataObject table } +\section{Development review}{ + +\itemize{ +\item AI-assisted: No +\item Human review: rix133 +} +} + diff --git a/man/generateMissingSSRows.Rd b/man/generateMissingSSRows.Rd index 3b716a05..f5f0fb89 100644 --- a/man/generateMissingSSRows.Rd +++ b/man/generateMissingSSRows.Rd @@ -37,6 +37,14 @@ OR "Lan"+"Dis". In the latter case, if one is missing the other is to be assumed 0. This function generates SS rows for any missing catch fractions. } +\section{Development review}{ + +\itemize{ +\item AI-assisted: No +\item Human review: rix133 +} +} + \examples{ # To follow } diff --git a/man/generateTestTbls.Rd b/man/generateTestTbls.Rd index 1b285123..bda251fc 100644 --- a/man/generateTestTbls.Rd +++ b/man/generateTestTbls.Rd @@ -13,7 +13,7 @@ generateTestTbls(tblNames, prevTbls = list(), ...) Defaults to empty list} \item{...}{ - Arguments passed on to \code{\link[=makeTbl]{makeTbl}} + Arguments passed on to \code{\link{makeTbl}} \describe{ \item{\code{tblName}}{Name of the table} \item{\code{rows}}{numeric number of rows per parent record. Defaults to 4.} diff --git a/man/generateZerosUsingSL.Rd b/man/generateZerosUsingSL.Rd index e06b3785..a613303b 100644 --- a/man/generateZerosUsingSL.Rd +++ b/man/generateZerosUsingSL.Rd @@ -23,3 +23,11 @@ RDBES data frame where SA was complemented with species looked for examples for now see https://github.com/ices-eg/WK_RDBES/tree/master/WKRDB-EST2/chairs/Nuno } +\section{Development review}{ + +\itemize{ +\item AI-assisted: No +\item Human review: rix133 +} +} + diff --git a/man/getLinkedDataFromLevel.Rd b/man/getLinkedDataFromLevel.Rd index 45f627ae..7b135103 100644 --- a/man/getLinkedDataFromLevel.Rd +++ b/man/getLinkedDataFromLevel.Rd @@ -18,11 +18,21 @@ getLinkedDataFromLevel(field, values, rdbesTables, level, verbose = FALSE) \item{verbose}{Logical flag indicating whether to print detailed information about the data retrieval process. Default is \code{FALSE}.} } \value{ -The subset of the table at the specified \code{level}. +A data.table containing the requested \code{field} and all columns of the +table at \code{level}, with one row per unique requested value and linked record. +Intermediate hierarchy IDs are not added. Column order is not guaranteed. } \description{ The \code{getLinkedDataFromLevel} function facilitates the retrieval of linked data between different levels of RDBES tables. Depending on the relative positions of the source and target tables within the \code{RDBESDataObject}, the function determines whether to traverse "up" or "down" the data hierarchy to obtain the desired linked data. } +\section{Development review}{ + +\itemize{ +\item AI-assisted: No +\item Review: rix133 +} +} + \examples{ \dontrun{ # Example 1: Going up in the table hierarchy to retrieve data from the DE table diff --git a/man/getLowerTableSubsets.Rd b/man/getLowerTableSubsets.Rd index 6b4d576e..bedde34d 100644 --- a/man/getLowerTableSubsets.Rd +++ b/man/getLowerTableSubsets.Rd @@ -41,3 +41,12 @@ The function recursively intersects the rows of the target lower level table tha the values from each subset in the upper tables. It then ensures that only unique rows are returned, based on the ID column of the target table. } +\section{Development review}{ + +\itemize{ +\item AI-assisted: Yes +\item Review: rix133 +} +} + +\keyword{internal} diff --git a/man/importRDBESDataCSV.Rd b/man/importRDBESDataCSV.Rd index 9d564a49..55bdfad0 100644 --- a/man/importRDBESDataCSV.Rd +++ b/man/importRDBESDataCSV.Rd @@ -36,11 +36,21 @@ an empty RDBESDataObject will be returned. Create an R object from a folder containing .csv data files downloaded from the RDBES upload/download page. } +\section{Development review}{ + +\itemize{ +\item AI-assisted: No +\item Review: rix133 +\item Notes/scope: Added tests dealing with over integer limit +} +} + \examples{ \dontrun{ myEmptyRDBESObject <- importRDBESDataCSV() rdbesExtractPath <- "./tests/testthat/h7_v_1_19_18/" obj <- importRDBESDataCSV(rdbesExtractPath) } + } \keyword{internal} diff --git a/man/joinDT.Rd b/man/joinDT.Rd new file mode 100644 index 00000000..e4c8d1ac --- /dev/null +++ b/man/joinDT.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/joinDT.R +\name{joinDT} +\alias{joinDT} +\title{Join two tables using data.table} +\usage{ +joinDT(x, y, by, type = c("left", "inner", "right"), suffix = c(".x", ".y")) +} +\arguments{ +\item{x, y}{data.frames or data.tables to join.} + +\item{by}{Character vector of key column names. Use a named vector, e.g. +\code{c("SSyear" = "SLyear")}, when the key columns have different names in +\code{x} (names) and \code{y} (values). Only the \code{x} key columns are kept.} + +\item{type}{The type of join: \code{"left"} keeps all rows of \code{x}, \code{"inner"} +keeps only matching rows and \code{"right"} keeps all rows of \code{y}.} + +\item{suffix}{Character vector of length 2 added to the names of non-key +columns found in both \code{x} and \code{y}. Use \code{""} to keep the names of one +table unchanged.} +} +\value{ +A data.table if \code{x} is a data.table, otherwise a data.frame. +} +\description{ +Internal replacement for \code{dplyr::left_join()}, \code{dplyr::inner_join()} and +\code{dplyr::right_join()}, built on \code{data.table::merge()} with \code{sort = FALSE}. +The output follows dplyr's conventions: +\itemize{ +\item rows are returned in the order of \code{x}, each \code{x} row followed by all its +matching \code{y} rows in the order they appear in \code{y}. A right join appends +the unmatched \code{y} rows at the end; +\item columns are the columns of \code{x} followed by the non-key columns of \code{y}; +\item non-key columns found in both tables get \code{suffix} added to their names; +\item \code{NA} key values match each other and many-to-many matches return all +combinations; +\item an integer key joined to a double key gives a double key. +} +} +\details{ +Differences from dplyr: if a suffixed name is already taken, \code{joinDT()} +gives an error (dplyr adds the suffix again). Other combinations of key +types follow data.table's join rules (e.g. a factor or logical key keeps the +type and levels of \code{x}, and joining factor or logical keys to other types +can give an error). + +The input tables are not modified. +} +\section{Development review}{ + +\itemize{ +\item AI-assisted: Yes +\item Human review: rix133 +\item Notes/scope: Written to remove the dplyr dependency. Tested on +every join made by the package test suite (~12k joins currently). +} +} + +\keyword{internal} diff --git a/man/lowerTblData.Rd b/man/lowerTblData.Rd index 20673c43..6d1e87ee 100644 --- a/man/lowerTblData.Rd +++ b/man/lowerTblData.Rd @@ -4,7 +4,15 @@ \alias{lowerTblData} \title{Get lower table data from upper table id} \usage{ -lowerTblData(field, values, tbls, level, verbose = FALSE, path_order = NULL) +lowerTblData( + field, + values, + tbls, + level, + verbose = FALSE, + requestedField = field, + requestedValues = values +) } \arguments{ \item{field}{A character string specifying the name of the upper table field.} @@ -16,10 +24,17 @@ lowerTblData(field, values, tbls, level, verbose = FALSE, path_order = NULL) \item{level}{A character string specifying the name of the target lower level table.} \item{verbose}{A logical value indicating whether to print intermediate levels during recursion.} + +\item{requestedField}{Internal: the originally requested field, carried +through the recursion (default \code{field}).} + +\item{requestedValues}{Internal: the originally requested value belonging to +each element of \code{values}, carried through the recursion (default \code{values}).} } \value{ -A data frame containing the rows of the target lower level table that are associated with -the given values of the upper table field. +A data.table with the originally requested field and all columns of +the \code{level} table. No intermediate hierarchy IDs are added. It has one row +per unique requested value and linked \code{level} record. } \description{ This function takes an upper table field name, values for that field, a list of tables, @@ -28,6 +43,14 @@ that are associated with the given values of the upper table field. NB! running on the RDBESDataObject will work properly if it is sorted by default the tables are not in the correct order for a specific hierarchy. } +\section{Development review}{ + +\itemize{ +\item AI-assisted: Yes +\item Review: rix133 +} +} + \examples{ # it is important to run the function only on the sorted RDBESDataObject RDBEScore:::lowerTblData("TEid", c(4), sort(H8ExampleEE1), "SA", TRUE) diff --git a/man/makeDT.Rd b/man/makeDT.Rd new file mode 100644 index 00000000..ed09cdde --- /dev/null +++ b/man/makeDT.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{makeDT} +\alias{makeDT} +\title{makeDT} +\usage{ +makeDT(x) +} +\arguments{ +\item{x}{A data.frame, or \code{NULL}.} +} +\value{ +A data.table, or \code{NULL} if \code{x} is \code{NULL}. +} +\description{ +Converts one element of a list of data.frames into a data.table, leaving +\code{NULL} elements as \code{NULL}. Used for each RDBES table in +\code{importRDBESDataDFS()}. +} +\keyword{internal} diff --git a/man/removeBrokenSpeciesListLinks.Rd b/man/removeBrokenSpeciesListLinks.Rd index 779d5893..d4c02814 100644 --- a/man/removeBrokenSpeciesListLinks.Rd +++ b/man/removeBrokenSpeciesListLinks.Rd @@ -2,9 +2,7 @@ % Please edit documentation in R/removeBrokenSpeciesListLinks.R \name{removeBrokenSpeciesListLinks} \alias{removeBrokenSpeciesListLinks} -\title{Remove rows which are not pointing to a valid SpecliestListDetails (SL) -records i.e.those rows which have a value of SpeciesListName that does not -exist in the SL table.} +\title{Remove SS rows with broken species-list links} \usage{ removeBrokenSpeciesListLinks(objectToCheck, verbose = FALSE, strict = TRUE) } @@ -12,20 +10,26 @@ removeBrokenSpeciesListLinks(objectToCheck, verbose = FALSE, strict = TRUE) \item{objectToCheck}{an RDBESDataObject.} \item{verbose}{(Optional) If set to TRUE more detailed text will be printed -out by the function. Default is TRUE.} +out by the function. Default is FALSE.} \item{strict}{(Optional) This function validates its input data - should the validation be strict? The default is TRUE.} } \value{ -an RDBESDataObject with any records with an invalid SpeciesListName -rows removed +an RDBESDataObject with SS rows without a matching SL record removed. } \description{ -Remove rows which are not pointing to a valid SpecliestListDetails (SL) -records i.e.those rows which have a value of SpeciesListName that does not -exist in the SL table. +A species-list link matches the list name, catch fraction, design year +and sampling country against the SL table. } +\section{Development review}{ + +\itemize{ +\item AI-assisted: Yes +\item Review: rix133 +} +} + \examples{ \dontrun{ diff --git a/man/removeBrokenVesselLinks.Rd b/man/removeBrokenVesselLinks.Rd index e3cc6c54..240ed0b8 100644 --- a/man/removeBrokenVesselLinks.Rd +++ b/man/removeBrokenVesselLinks.Rd @@ -23,6 +23,14 @@ an RDBESDataObject with any records with an invalid VDid removed Remove rows which are not pointing to a valid VesselDetails (VD) records i.e. those rows which have a value of VDid that does not exist in the VD table. } +\section{Development review}{ + +\itemize{ +\item AI-assisted: No +\item Human review: rix133 +} +} + \examples{ \dontrun{ diff --git a/man/shrimps.Rd b/man/shrimps.Rd deleted file mode 100644 index e5833086..00000000 --- a/man/shrimps.Rd +++ /dev/null @@ -1,38 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data.R -\docType{data} -\name{shrimps} -\alias{shrimps} -\title{One quarter of sample data from swedish shrimp landings of the -SWE_OTB_CRU_32-69_0_0 fishery} -\format{ -A data frame with 10 rows and 95 variables: -\itemize{ -\item DEsamplingScheme - Sampling Scheme -\item DEyear - Year of data collection -\item DEstratumName - Fishery code -\item DEhierarchyCorrect - Design Variable of RDBES. More details in RDBES documentation -\item DEhierarchy - Design Variable of RDBES. More details in RDBES documentation -\item DEsampled - Design Variable of RDBES. More details in RDBES documentation -\item DEreasonNotSampled - Design Variable of RDBES. More details in RDBES documentation -\item SDcountry - Country that collected the data -\item SDinstitution - Institution that collected the data -\item su1, su2, su3, su4, su5 - sampling units of RDBES. More details in RDBES documentation -\item XXXnumberSampled, ... - Design Variables of RDBES. More details in RDBES documentation -\item targetValue - estimate of weight landed in each haul (in kg) -\item plus XX other columns -} -} -\source{ -Nuno Prista @ SLU Aqua, 2022 -} -\usage{ -shrimps -} -\description{ -A dataset of rdbesEstimObj type containing simplified haul-level -samples (rows) of shrimp landings (targetValue, in kg) observed onboard using -H1 of RDBES with UPWOR on vessels. Data is provided for developing/testing -purposes only. -} -\keyword{datasets} diff --git a/man/shrimpsStrat.Rd b/man/shrimpsStrat.Rd deleted file mode 100644 index 0993a1c4..00000000 --- a/man/shrimpsStrat.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data.R -\docType{data} -\name{shrimpsStrat} -\alias{shrimpsStrat} -\title{One quarter of sample data from swedish shrimp catches of the -SWE_OTB_CRU_32-69_0_0 fishery} -\format{ -A data frame with 10 rows and 95 variables: -\itemize{ -\item DEsamplingScheme - Sampling Scheme -\item DEyear - Year of data collection -\item DEstratumName - Fishery code -\item DEhierarchyCorrect - Design Variable of RDBES. More details in RDBES documentation -\item DEhierarchy - Design Variable of RDBES. More details in RDBES documentation -\item DEsampled - Design Variable of RDBES. More details in RDBES documentation -\item DEreasonNotSampled - Design Variable of RDBES. More details in RDBES documentation -\item SDcountry - Country that collected the data -\item SDinstitution - Institution that collected the data -\item su1, su2, su3, su4, su5 - sampling units of RDBES. More details in RDBES documentation -\item XXXnumberSampled, ... - Design Variables of RDBES. More details in RDBES documentation -\item su5stratumName - sieve fraction -\item targetValue - estimate of weight fraction in each haul (in kg) -\item plus XX other columns -} -} -\source{ -Nuno Prista @ SLU Aqua, 2022 -} -\usage{ -shrimpsStrat -} -\description{ -A dataset of rdbesEstimObj type containing simplified haul-level -samples (rows) of shrimp catches (targetValue, in kg) observed onboard using -H1 of RDBES with UPWOR on vessels. Catches are divided into three strata (91, 92, 93_94) -that correspond to sorting sieves used onboard. Data is provided for developing/testing -purposes only. -} -\keyword{datasets} diff --git a/man/updateSAwithTaxonFromSL.Rd b/man/updateSAwithTaxonFromSL.Rd index 34f15429..952246e4 100644 --- a/man/updateSAwithTaxonFromSL.Rd +++ b/man/updateSAwithTaxonFromSL.Rd @@ -44,6 +44,14 @@ or genus then the function retains the original SA species code. function also retains the original SA species code. } } +\section{Development review}{ + +\itemize{ +\item AI-assisted: No +\item Human review: rix133 +} +} + \examples{ \dontrun{ myObject <- createRDBESDataObject(input = "WGRDBES-EST/personal/Kasia/vignettes/vignetteData") diff --git a/man/upperTblData.Rd b/man/upperTblData.Rd index 1ae01aae..2a4f61ae 100644 --- a/man/upperTblData.Rd +++ b/man/upperTblData.Rd @@ -4,7 +4,15 @@ \alias{upperTblData} \title{Get Field from Upper Table} \usage{ -upperTblData(field, values, tbls, level, verbose = FALSE) +upperTblData( + field, + values, + tbls, + level, + verbose = FALSE, + requestedField = field, + requestedValues = values +) } \arguments{ \item{field}{A character string specifying the field to get.} @@ -16,6 +24,10 @@ upperTblData(field, values, tbls, level, verbose = FALSE) \item{level}{A character string specifying the level to get data from.} \item{verbose}{(Optional) Set to TRUE if you want informative text printed} + +\item{requestedField}{Internal: the originally requested field.} + +\item{requestedValues}{Internal: the original value for each element of \code{values}.} } \value{ A data frame containing rows from an upper table that match the @@ -34,12 +46,20 @@ values and returns the result. NB! running on the RDBESDataObject will work properly if it is sorted by default the tables are not in the correct order for a spesific hierarchy. } +\section{Development review}{ + +\itemize{ +\item AI-assisted: Yes +\item Review: rix133 +} +} + \examples{ # it is important to run these functions only on sorted RDBESDataObject RDBEScore:::upperTblData("SAid", c(1), sort(H8ExampleEE1), "DE", verbose = TRUE) DE <- data.table::data.table(DEid = c(1, 2)) SD <- data.table::data.table(SDid = c(1, 2), DEid = c(1, 2)) -VS <- data.table::data.table(VSid = c(1, 2),SDid =c(1,2), value = c(10, 20)) +VS <- data.table::data.table(VSid = c(1, 2),SDid =c(1,2), VSvalue = c(10, 20)) tbls <- list(DE = DE, SD = SD, VS = VS) RDBEScore:::upperTblData("VSid", c(1), tbls, "DE") } diff --git a/man/validateRDBESDataObjectDataTypes.Rd b/man/validateRDBESDataObjectDataTypes.Rd index 2409fab4..d7bd41fb 100644 --- a/man/validateRDBESDataObjectDataTypes.Rd +++ b/man/validateRDBESDataObjectDataTypes.Rd @@ -20,3 +20,11 @@ Checks the data types of the columns in an RDBESDataObject against an expected list of data types. Any differences are returned } +\section{Development review}{ + +\itemize{ +\item AI-assisted: No +\item Human review: rix133 +} +} + diff --git a/package_overview.Rmd b/package_overview.Rmd index 6bc617cc..72a12ad6 100644 --- a/package_overview.Rmd +++ b/package_overview.Rmd @@ -2,51 +2,54 @@ title: 'RDBEScore: Using R for ICES Regional Database & Estimation System (RDBES) Data' output: - ioslides_presentation: - incremental: true powerpoint_presentation: reference_doc: "./data-raw/styles.pptx" slide_level: 2 keep_md: true incremental: true + ioslides_presentation: + incremental: true beamer_presentation: incremental: true --- -## Importing RDBES Data +## Introduction -The aim of this document is to outline the basic workflow of importing data downloaded from the [ICES Regional Database & Estimation System (RDBES)](https://rdbes.ices.dk/#/) or a `list` object containing data frames (or data.tables) into `R` using the `RDBEScore` package. +**RDBEScore** is an R package developed to facilitate the analysis of data from the ICES Regional Database and Estimation System (RDBES). The package provides functions to: -The function **createRDBESDataObject** is intended to directly import Commercial Landing (CL), Commercial Effort (CE) and Commercial Sampling (CS) tables downloaded from [RDBES](https://rdbes.ices.dk/#/). +- import functions like `createRDBESDataObject` and `validateRDBESDataObject` +- manipulate functions such as `filterAndTidyRDBESDataObject`, `combineRDBESDataObjects` and `removeBrokenVesselLinks` +- analysis functions including `createRDBESEstObject`, `doEstimationForAllStrata`, `doBVestimCANUM` and `exportEstimationResultsToInterCatchFormat` to generate estimates and export them to InterCatch format. -## Introduction -2 -RDBEScore is an R package developed to facilitate the analysis of data from the ICES Regional Database and Estimation System (RDBES). The package provides functions to: +These functions support the entire workflow from data import through cleaning to estimation and reporting. The package is designed to work with data from the RDBES, which is a relational database system used by ICES to store data from regional sampling programmes. The `RDBEScore` package is intended to be used by national data coordinators, data analysts, and scientists working with data from the RDBES. -- import functions like `createRDBESDataObject` and `validateRDBESDataObject` -- manipulate functions like `filterAndTidyRDBESDataObject`, `combineRDBESDataObjects` and `removeBrokenVesselLinks` -- analyse functions like +The aim of this document is to outline the basic workflow of importing and processing data downloaded from the [ICES Regional Database & Estimation System (RDBES)](https://rdbes.ices.dk/#/) -data from the RDBES. The package is designed to work with data from the RDBES, which is a relational database system used by ICES to store data from regional sampling programmes. The `RDBEScore` package is intended to be used by national data coordinators, data analysts, and scientists working with data from the RDBES. +## RDBEScore package +The package can be found on [RDBEScore GitHub](https://github.com/ices-tools-dev/RDBEScore). -## RDBEScore package +The best way to get started is to read the package documentation and the vignettes. The package documentation can be found on the [RDBEScore GitHub pages](https://ices-tools-dev.github.io/RDBEScore/), which describe the installation methods and provide worked examples for the available functions under **articles** section. -The package can be found on [RDBEScore GitHub](https://github.com/ices-tools-dev/RDBEScore/tree/dev) +These resources provide information on how to install the package, how to use the functions, and how to contribute to the development of the package. The following will now demonstrate some of the functionality of the package using the current **main** version. -The best way to get started is to read the package documentation and the vignettes. The package documentation can be found on the [RDBEScore GitHub pages](https://ices-tools-dev.github.io/RDBEScore/). -These resources provide information on how to install the package, how to use the functions, and how to contribute to the development of the package. The following will now demonstrate some of the functionality of the package that is available now at the **dev** branch. +## Installation +The most recent production version of **RDBEScore** can be installed using the ICES tools production repository: -## Load RDBEScore Development Version +```{r eval=FALSE, echo=TRUE} +install.packages("RDBEScore", + repos = c("https://ices-tools-prod.r-universe.dev", + "https://cloud.r-project.org")) +``` -The suggested way to install the package is from the `main` or development (`dev`) branch on GitHub using the `remotes` package. +A more recent development version is available from GitHub: ```{r eval=FALSE, echo=TRUE} install.packages("remotes") -remotes::install_github("ices-tools-dev/RDBEScore@dev", build_vignettes = TRUE) +remotes::install_github("ices-tools-dev/RDBEScore/dev", build_vignettes = TRUE) ``` Then you can load the package using: @@ -61,6 +64,15 @@ To see the complete list of vignettes available in the package use the following browseVignettes(package = "RDBEScore") ``` +## Downloading RDBES data (dev) + +The data can be downloaded from the [RDBES](https://rdbes.ices.dk/#/) or using the package function **downloadRDBESDataZip()**. This function allows you to download the data for a specific country and year directly from RDBES into a folder of your choice. The CS data is downloaded as a `.zip` file containing all the mandatory hierarchy tables plus VD and SL. + +```{r} +downloadRDBESDataZip(datatype = "CS", year = 1965, country = "ZW", + hierarchy = 1, dir = "./data-raw/exampleData") +``` + ## Importing zipped files @@ -73,7 +85,8 @@ importedH1 <- createRDBESDataObject(input = "./data-raw/exampleData/H1_2025_02_1 names(importedH1[!unlist(lapply(importedH1, is.null))]) ``` -For this to work the zip file should contain these tables in the root of the zip file. +You can only read in one hierarchy at a time. If the zip file contains multiple hierarchies you need to read them separately. + ## Data Object Structure @@ -138,7 +151,7 @@ myFilteredObject <- filterRDBESDataObject(H1Example, myFilteredObject ``` -## Remowing Unlinked Data +## Removing Unlinked Data It is important to note that filtering is likely to result in "orphan" rows being produced so it is usual to also apply the **findAndKillOrphans()** function to the filtered data to remove these records. @@ -166,8 +179,6 @@ ld <- getLinkedDataFromLevel("LEid", c(1), H8ExampleEE1, "TE", verbose = TRUE) knitr::kable(ld[,c(1:2,5:8 )]) ``` -## Getting Subsets of RDBESDataObject Tables - Similarly we can get the subset of the LE table corresponding to a specific value in the TE table. This does not have to be the *id* field, but can be any field in the table. ```{r} @@ -184,6 +195,14 @@ ld <- getLinkedDataFromLevel("BVfishId", c("410472143", "410472144"), H8ExampleE knitr::kable(ld[,1:5]) ``` +## Data Preparation: Handling Zeros and NAs + +Before estimation, it is often necessary to ensure the data is complete, particularly regarding species that were looked for but not found (zeros) or not targeted (NAs). **RDBEScore** provides functions to handle this using the Species List (SL) table. + +- `generateZerosUsingSL()`: Adds explicit zero records for species recorded in the species list but missing from the sample. +- `generateNAsUsingSL()`: Populates NA values for species not targeted by the sampling scheme. + +See the vignettes *Generating zeros for species not observed* and *Generating NAs for species not targeted by sampling* for more details. ## Estimating @@ -211,7 +230,7 @@ estimMC(as.numeric(BV$BVvalueMeas), Right now estimation actually is done on a *RDBESEstObject* that is generate from *RDBESDataObject* using **createRDBESEstObject(...)**. -In the next sections we will use data from R packages [survey](https://CRAN.R-project.org/package=survey) and [SDAResources](https://CRAN.R-project.org/package=SDAResources) that are converted into the *RDBESDataObject* to demonstrate the estimation procedure. +In the next sections we will use example data derived from the [survey](https://CRAN.R-project.org/package=survey) and [SDAResources](https://CRAN.R-project.org/package=SDAResources) packages. This data is included in **RDBEScore** and converted into the *RDBESDataObject* format to demonstrate the estimation procedure. For more detailed information on the estimation functions see the vignettes @@ -243,7 +262,7 @@ How to interpret these results in the above example? In practice the data submitters have to prepare Intercatch data call tables. In the future the estimation functions should be made so that they estimate the values for these tables. -in the **dev** branch there is a function **doBVestimCANUM(...)** that can be used for a very basic estimation of the total catch at number (CANUM) for a specified biological variable, such as age or length. +The package includes a function **doBVestimCANUM(...)** that can be used for a basic estimation of the total catch at number (CANUM) for a specified biological variable, such as age or length. ### Simple Estimation Example @@ -252,7 +271,7 @@ in the **dev** branch there is a function **doBVestimCANUM(...)** that can be us For the simplest case of estimation we need the **RDBESDataObject** with CS tables and a CL table. In the following example we will estimate the total number of sprat caught in the area *27.3.d.28.1* with the gear *OTM_SPF_16-31_0_0* for the first quarter of the year. ```{r} -#From the commertial landings table we need to get the total weight of the catches +#From the commercial landings table we need to get the total weight of the catches CLfieldstoSum <- c("CLoffWeight") ``` @@ -276,8 +295,7 @@ strataListCL <- list(CLarea="27.3.d.28.1", ## Adding CL data to the lower hierarchy - -There is a function in development **addCLtoLowerCS(...)** that can be used to add the CL data to the lower hierarchy. +The function **addCLtoLowerCS(...)** can be used to add the commercial landings (CL) data to the lower hierarchy, enabling estimation of biological variables using corresponding landing weights. ```{r} @@ -289,8 +307,7 @@ biolCLQ1 <- addCLtoLowerCS(H8ExampleEE1, strataListCS, strataListCL, ``` ## Estimation based on CL and BV - -To estimate the total number of sprat caught in the area 27.3.d.28.1 with the gear OTM_SPF_16-31_0_0 for the first quarter of the year we need to use the function **doBVestimCANUM(...)**. For more details on the function see the vignette in the **dev** branch. +To estimate the total number of sprat caught in the area 27.3.d.28.1 with the gear OTM_SPF_16-31_0_0 for the first quarter of the year we need to use the function **doBVestimCANUM(...)**. Details on this function and the overall estimation workflow are provided in the vignettes. The output table should be enough to populate a classic InterCatch data call table. ```{r canNum} @@ -304,6 +321,72 @@ knitr::kable(lenCANUMQ1[order(lenCANUMQ1$LengthmmMean), c("Group", "WeightgMean" ``` +## Exporting Results + +The results can be formatted for the InterCatch data call using **exportEstimationResultsToInterCatchFormat()**. +To do this we need to map the columns in our calculated object to the column names expected by the export function. + +```{r} +# Add extra columns to the final result +addCols <- c(names(strataListCS), + names(strataListCL), + paste0('sum', CLfieldstoSum)) + +ageCANUM <- doBVestimCANUM(biolCLQ1, addCols, + classUnits = "Ageyear", + classBreaks = 1:8, + verbose = FALSE) + +# Map the results to InterCatch format +dataToExport <- data.frame( + # HI columns + Country = "EE", + Year = "2022", + SeasonType = "Quarter", + Season = ageCANUM$CLquar, + Fleet = ageCANUM$CLmetier6, + AreaType = "Div", + FishingArea = ageCANUM$CLarea, + DepthRange = "NA", + + # SI columns + Species = ageCANUM$SAspeCodeFAO, + Stock = "Unknown", + CatchCategory = "L", + ReportingCategory = "R", + DataToFrom = "Data", + Usage = "Used", + SamplesOrigin = "U", + QualityFlag = "U", + UnitCATON = "kg", + CATON = ageCANUM$sumCLoffWeight, + OffLandings = ageCANUM$sumCLoffWeight, + + # SD columns + Sex = "N", + CANUMtype = "L", + AgeLength = as.integer(as.character(ageCANUM$Group)), + PlusGroup = ageCANUM$plusGroup, + unitMeanWeight = "g", + unitCANUM = "n", + UnitAgeOrLength = "Age", + UnitMeanLength = "mm", + NumberCaught = ageCANUM$totNum, + MeanWeight = ageCANUM$WeightgMean, + MeanLength = ageCANUM$LengthmmMean +) + +# Generate the InterCatch string +ic_output <- exportEstimationResultsToInterCatchFormat(dataToExport) + +# Show the first few lines of the output +head(ic_output) +``` + +See the vignettes 03b (ratio estimation) or 04b (stratified estimation) for more detailed examples and explanations of the estimation workflow and exporting results to InterCatch format. + + + ## Issues Reporting If something is not working as expected, or if you have a feature request, please open an issue on [RDBEScore GitHub](https://github.com/ices-tools-dev/RDBEScore/issues) diff --git a/tests/testthat/bigid/SamplingDetails.csv b/tests/testthat/bigid/SamplingDetails.csv new file mode 100644 index 00000000..4b059064 --- /dev/null +++ b/tests/testthat/bigid/SamplingDetails.csv @@ -0,0 +1,9 @@ +SDid,DEid,SDrecordType,SDcountry,SDinstitution +3000415656,5351,SD,ZW,4484 +5425,5393,SD,ZW,4484 +5434,5402,SD,ZW,4484 +5435,5403,SD,ZW,4484 +5436,5404,SD,ZW,4484 +5438,5406,SD,ZW,1051 +5439,5407,SD,ZW,1051 +5440,5408,SD,ZW,1051 diff --git a/tests/testthat/test-addCLtoLowerCS.R b/tests/testthat/test-addCLtoLowerCS.R index f206ecda..52c33c8f 100644 --- a/tests/testthat/test-addCLtoLowerCS.R +++ b/tests/testthat/test-addCLtoLowerCS.R @@ -34,6 +34,33 @@ test_that("addCLtoLowerCS adds the correct sumCLoffWeight column with valid inpu expect_equal(result$sumCLoffWeight[1], 396210) }) +test_that("addCLtoLowerCS supports multiple CL values for a stratum", { + strataListCS_multiquarter <- list( + LEarea = "27.3.d.28.1", + LEmetier6 = "OTM_SPF_16-31_0_0", + TEstratumName = month.name[1:6], + SAspeCodeFAO = "SPR" + ) + strataListCL_multiquarter <- list( + CLarea = "27.3.d.28.1", + CLquar = 1:2, + CLmetier6 = "OTM_SPF_16-31_0_0", + CLspecFAO = "SPR" + ) + + result <- expect_warning(addCLtoLowerCS( + mock_rdbes, + strataListCS_multiquarter, + strataListCL_multiquarter, + combineStrata = TRUE, + lowerHierarchy = "C", + CLfields = c("CLoffWeight") + )) + + expect_true(nrow(result) > 0) + expect_equal(unique(result$sumCLoffWeight), 443832) +}) + # Test 4: Check that the function handles unsupported lowerHierarchy correctly test_that("addCLtoLowerCS throws an error if lowerHierarchy is unsupported", { expect_error( diff --git a/tests/testthat/test-detectNonExportedFunctionsInExamples.R b/tests/testthat/test-detectNonExportedFunctionsInExamples.R new file mode 100644 index 00000000..f7fadf3e --- /dev/null +++ b/tests/testthat/test-detectNonExportedFunctionsInExamples.R @@ -0,0 +1,124 @@ +#' - AI-assisted: Yes +#' - Review: +#' - Notes/scope: not really reviewed, just worked when needed +#' + +test_that("detectNonExportedFunctionsInExamples finds non-exported functions in examples", { + pkg_path <- tempfile("testpkg-") + dir.create(pkg_path) + dir.create(file.path(pkg_path, "R")) + dir.create(file.path(pkg_path, "man")) + + # Minimal package metadata + writeLines( + c( + "Package: testpkg", + "Title: Test Package", + "Version: 0.0.1", + "Description: A package for testing.", + "License: MIT" + ), + file.path(pkg_path, "DESCRIPTION") + ) + + # Define one exported and one internal function + writeLines( + c( + "export(public_fun)" + ), + file.path(pkg_path, "NAMESPACE") + ) + + writeLines( + c( + "public_fun <- function(x) x", + "internal_fun <- function(x) x" + ), + file.path(pkg_path, "R", "functions.R") + ) + + # Help page example calls the internal function + writeLines( + c( + "\\name{public_fun}", + "\\alias{public_fun}", + "\\title{Public function}", + "\\description{A test help page.}", + "\\examples{", + "public_fun(1)", + "internal_fun(1)", + "}" + ), + file.path(pkg_path, "man", "public_fun.Rd") + ) + + result <- detectNonExportedFunctionsInExamples(pkg_path) + + expect_true(is.data.frame(result)) + expect_true(all(c( + "topic", "function_name", "call_type", "defined_in_package" + ) %in% names(result))) + + expect_true(any( + result$function_name == "internal_fun" & + result$defined_in_package + )) + + # Clean up + unlink(pkg_path, recursive = TRUE) +}) + +test_that("detectNonExportedFunctionsInExamples ignores exported functions", { + pkg_path <- tempfile("testpkg-") + dir.create(pkg_path) + dir.create(file.path(pkg_path, "R")) + dir.create(file.path(pkg_path, "man")) + + writeLines( + c( + "Package: testpkg", + "Title: Test Package", + "Version: 0.0.1", + "Description: A package for testing.", + "License: MIT" + ), + file.path(pkg_path, "DESCRIPTION") + ) + + # Both functions are defined, but only public_fun is exported + writeLines( + "export(public_fun)", + file.path(pkg_path, "NAMESPACE") + ) + + writeLines( + c( + "public_fun <- function(x) x", + "internal_fun <- function(x) x" + ), + file.path(pkg_path, "R", "functions.R") + ) + + # The example calls only the exported function + writeLines( + c( + "\\name{public_fun}", + "\\alias{public_fun}", + "\\title{Public function}", + "\\description{A test help page.}", + "\\examples{", + "public_fun(1)", + "}" + ), + file.path(pkg_path, "man", "public_fun.Rd") + ) + + result <- detectNonExportedFunctionsInExamples(pkg_path) + + expect_false(any(result$function_name == "public_fun")) + + # Clean up + unlink(pkg_path, recursive = TRUE) + +}) + diff --git a/tests/testthat/test-filterRDBESDataObjects.R b/tests/testthat/test-filterRDBESDataObjects.R index 6905305b..cc3ad01d 100644 --- a/tests/testthat/test-filterRDBESDataObjects.R +++ b/tests/testthat/test-filterRDBESDataObjects.R @@ -151,8 +151,10 @@ test_that("filterRDBESDataObject does not removes orphans when killOrphans = FAL test_that("filterRDBESDataObject retains FT if filtering by FO", { #issue #183 problem with filtering by FOid but not SSid? myH1RawObject <- Pckg_survey_apistrat_H1 + #take the first FOid becasue if data is updated the id field value might change + foId2use <- myH1RawObject$FO$FOid[1] - resFO <- filterRDBESDataObject(myH1RawObject, "FOid", 70849, + resFO <- filterRDBESDataObject(myH1RawObject, "FOid", foId2use, killOrphans = F) expect_equal(nrow(resFO$FO), 1) expect_equal(nrow(resFO$FT), 200) @@ -171,8 +173,10 @@ test_that("filterRDBESDataObject filter correctly for FT and FO", { #although it is not very flexible as you might want to filter on an id field # but this requires explicitly stating on the call the table where the id is expected. myH1RawObject <- Pckg_survey_apistrat_H1 + #take the first FOid becasue if data is updated the id field value might change + foId2use <- myH1RawObject$FO$FOid[1] - resFO <- filterRDBESDataObject(myH1RawObject, "FOid", 70849, + resFO <- filterRDBESDataObject(myH1RawObject, "FOid", foId2use, killOrphans = TRUE) expect_equal(nrow(resFO$FO), 1) FTid <- resFO$FO$FTid @@ -185,7 +189,7 @@ test_that("filterRDBESDataObject filter correctly for FT and FO", { test_that("filterRDBESDataObject filter correctly for FO and SS", { #issue #183 problem with filtering by FOid but not SSid? myH1RawObject <- Pckg_survey_apistrat_H1 - values2filter <- c(227694) + values2filter <- c(Pckg_survey_apistrat_H1$SS$SSid[1]) fields2filter <- c("SSid") resSS <- filterRDBESDataObject(myH1RawObject, fields2filter, values2filter, killOrphans = TRUE) @@ -199,7 +203,7 @@ test_that("filterRDBESDataObject filter correctly for FO and SS", { test_that("filterRDBESDataObject filter correctly for SS and SA", { #issue #183 problem with filtering by FOid but not SSid? myH1RawObject <- Pckg_survey_apistrat_H1 - values2filter <- c(227694) + values2filter <- c(Pckg_survey_apistrat_H1$SA$SAid[1]) fields2filter <- c("SSid") resSS <- filterRDBESDataObject(myH1RawObject, fields2filter, values2filter, killOrphans = TRUE) diff --git a/tests/testthat/test-findAndKillOrphans.R b/tests/testthat/test-findAndKillOrphans.R index cb149d19..53fec82b 100644 --- a/tests/testthat/test-findAndKillOrphans.R +++ b/tests/testthat/test-findAndKillOrphans.R @@ -53,4 +53,56 @@ test_that("findAndKillOrphans removes orphans on an filtered RDBESDataObject", }) +test_that("findAndKillOrphans does not remove upstream rows when lower-level rows are removed", { + + myH1RawObject <- importRDBESDataCSV(rdbesExtractPath = "./h1_v_20250211") + + # Keep a small stable subset first + myH1RawObject <- filterRDBESDataObject( + myH1RawObject, + fieldsToFilter = c("DEstratumName"), + valuesToFilter = c("DE_stratum1_H1", "DE_stratum2_H1", "DE_stratum3_H1") + ) + + # Start from an object without pre-existing orphans + myH1RawObject <- findAndKillOrphans(myH1RawObject, verbose = FALSE) + + # Record the upstream state that should remain unchanged + expectedDEids <- sort(myH1RawObject$DE$DEid) + expectedSDids <- sort(myH1RawObject$SD$SDid) + expectedSDtoDE <- myH1RawObject$SD[order(SDid), .(SDid, DEid)] + + # Remove all VS rows only + myFilteredObject <- filterRDBESDataObject( + myH1RawObject, + fieldsToFilter = "VSunitName", + valuesToFilter = "blah" + ) + + expect_equal(nrow(myFilteredObject[["VS"]]), 0) + + # Kill downstream orphans created by removing VS + myObjectNoOrphans <- findAndKillOrphans( + objectToCheck = myFilteredObject, + verbose = FALSE + ) + + # Upstream tables must be unchanged + expect_equal(sort(myObjectNoOrphans$DE$DEid), expectedDEids) + expect_equal(sort(myObjectNoOrphans$SD$SDid), expectedSDids) + expect_equal( + myObjectNoOrphans$SD[order(SDid), .(SDid, DEid)], + expectedSDtoDE + ) + + # Downstream tables should be removed + expect_equal(nrow(myObjectNoOrphans[["VS"]]), 0) + expect_equal(nrow(myObjectNoOrphans[["FT"]]), 0) + expect_equal(nrow(myObjectNoOrphans[["FO"]]), 0) + expect_equal(nrow(myObjectNoOrphans[["SS"]]), 0) + expect_equal(nrow(myObjectNoOrphans[["SA"]]), 0) + expect_equal(nrow(myObjectNoOrphans[["FM"]]), 0) + expect_equal(nrow(myObjectNoOrphans[["BV"]]), 0) +}) + }) ## end capture.output diff --git a/tests/testthat/test-getLinkedDataFromLevel.R b/tests/testthat/test-getLinkedDataFromLevel.R index 362a9f1d..83d5877f 100644 --- a/tests/testthat/test-getLinkedDataFromLevel.R +++ b/tests/testthat/test-getLinkedDataFromLevel.R @@ -1,3 +1,6 @@ +# AI-assisted: Yes +# Review: rix133 +capture.output({ ## suppresses printing of console output when running test() # Test for Example 1: Going up in the table hierarchy to retrieve data from the DE table test_that("Retrieve data from DE based on BVid", { @@ -30,11 +33,31 @@ test_that("Retrieve data from VS based on BVfishId", { # Check that the result is a data.table (or other expected data structure) expect_s3_class(result, "data.table") - # Check that the result contains data (you can adjust this depending on known expected results) + expect_equal(nrow(result), 2) + expect_setequal(result$BVfishId, c("410472143", "410472144")) + +}) + +test_that("optional source tables can be linked to required tables", { + result <- getLinkedDataFromLevel( + "FTid", + H5Example$FT$FTid[1], + H5Example, + "DE" + ) + + expect_s3_class(result, "data.table") expect_equal(nrow(result), 1) +}) - # Optionally, check for specific values in the result +test_that("error when a required table is missing", { + h5 <- data.table::copy(H5Example) + h5[["SD"]] <- NULL + expect_error( + getLinkedDataFromLevel("DEid", c(1), h5, "BV"), + "Missing required tables in the RDBESDataObject: SD" + ) }) test_that("Error when rdbesTables is not of class RDBESDataObject", { @@ -56,7 +79,122 @@ test_that("Error when level is not found in rdbesTables", { ) }) +test_that("Error when mixed hierarchy in rdbesTables", { + obj <- data.table::copy(H8ExampleEE1) + # Add a DE row from a different hierarchy + obj[["DE"]] <- rbind(obj[["DE"]], H1Example[["DE"]][1]) + + + expect_error( + suppressWarnings( + getLinkedDataFromLevel("BVid", c(1), obj, "TE") + ), + "Mixed hierarchy RDBESDataObject!" + ) +}) + +test_that("Retrieve data from VS based on BVfishId if There is an empty intermedate FM table", { + h8 <- H8ExampleEE1 + + #add FM table to the rdbes object + h8[["FM"]] <- H1Example[["FM"]][0,] + + + + result <- getLinkedDataFromLevel("BVfishId", c("410472143", "410472144"), h8, "VS") + + # Check that the result is a data.table (or other expected data structure) + expect_s3_class(result, "data.table") + + expect_equal(nrow(result), 2) + expect_setequal(result$BVfishId, c("410472143", "410472144")) + + #check also downwards direction + res2 <- getLinkedDataFromLevel("DEid", c(1), h8, "BV") + + expect_s3_class(res2, "data.table") + expect_equal(nrow(res2), 3995) +}) + +test_that("Retrieve data from DE based on BVid retains the BVid field", { + result <- getLinkedDataFromLevel("BVid", c(1), H8ExampleEE1, "DE") + + # Check that the result is a data.table (or other expected data structure) + expect_s3_class(result, "data.table") + + # Check that the result has 1 row, as expected + expect_equal(nrow(result), 1) + + # Check that the result has the correct field + expect_true("BVid" %in% names(result)) + + # Check that the BVid field has the correct value + expect_equal(result$BVid, 1) +}) + +test_that("Retrieve data from TE based on DEid retains the DEid field", { + result <- getLinkedDataFromLevel("DEid", c(1), H8ExampleEE1, "TE") + + # Check that the result is a data.table (or other expected data structure) + expect_s3_class(result, "data.table") + + # Check that the result has 1 row, as expected + expect_equal(nrow(result), 11) + + # Check that the result has the correct field + expect_true("DEid" %in% names(result)) + + # Check that the DEid field has the correct value + expect_equal(result$DEid, c(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)) +}) + +test_that("Retrieve data from FO based on DEid retains the DEid field", { + result <- getLinkedDataFromLevel("DEid", c(5351,5393), H1Example, "FO") + + # Check that the result is a data.table (or other expected data structure) + expect_s3_class(result, "data.table") + + # Check that the result has 1 row, as expected + expect_equal(nrow(result), 320) + + # Check that the result has the correct field + expect_true("DEid" %in% names(result)) + + # Check that the DEid field has the correct value + expect_equal(result$DEid, c(rep(5351, 300), rep(5393, 20))) +}) + +test_that("Both traversal directions return the requested field and the target columns only", { + # downwards: requested field is not an id + down <- getLinkedDataFromLevel("TEstratumName", c("January", "February"), + H8ExampleEE1, "SA") + expect_setequal(names(down), c("TEstratumName", names(H8ExampleEE1$SA))) + expect_equal(nrow(down), 6) + expect_equal(sort(unique(down$TEstratumName)), c("February", "January")) + expect_equal(anyDuplicated(down[, c("TEstratumName", "SAid")]), 0) + + # upwards + up <- getLinkedDataFromLevel("SAid", c(1, 2), H8ExampleEE1, "TE") + expect_setequal(names(up), c("SAid", names(H8ExampleEE1$TE))) + expect_equal(up$SAid, c(1, 2)) + expect_equal(up$TEid, c(1, 1)) +}) + +test_that("Same-level queries follow the same output convention", { + result <- getLinkedDataFromLevel("TEstratumName", c("January", "February"), + H8ExampleEE1, "TE") + + expect_setequal(names(result), names(H8ExampleEE1$TE)) + expect_equal(anyDuplicated(names(result)), 0) + expect_equal(nrow(result), 4) +}) +test_that("Linked data does not contain intermediate hierarchy ids", { + result <- getLinkedDataFromLevel("DEid", c(1), H8ExampleEE1, "SA") + + expect_setequal(names(result), unique(c("DEid", names(H8ExampleEE1$SA)))) +}) +}) diff --git a/tests/testthat/test-getLowerTableSubsets.R b/tests/testthat/test-getLowerTableSubsets.R index a8bcc504..9bbeebf8 100644 --- a/tests/testthat/test-getLowerTableSubsets.R +++ b/tests/testthat/test-getLowerTableSubsets.R @@ -1,4 +1,9 @@ +# AI-assisted: Yes +# Review: rix133 +capture.output({ ## suppresses printing of console output when running test() + + # Define mock data for testing DE <- data.frame(DEid = c(1, 2, 3, 4), SDid = c(1, 2, 3, 4)) SD <- data.frame(SDid = c(1, 2, 3, 4), TEid = c(1, 2, 3, 4)) @@ -28,8 +33,7 @@ test_that("Function returns correct data with valid inputs", { res <- getLowerTableSubsets(list(TEstratumName = "January"), "SA", H8ExampleEE1, T) expect_equal(nrow(res), 3) - #expect last column to be "TEstratumName" - expect_equal(colnames(res)[ncol(res)], "TEstratumName") + expect_true("TEstratumName" %in% names(res)) }) @@ -37,10 +41,7 @@ test_that("Function works with combineStrata = TRUE and collapsing strata", { res <- expect_warning(getLowerTableSubsets(list(TEstratumName = c("January", "February")), "SA", H8ExampleEE1, T)) expect_equal(nrow(res), 6) - #expect last column to be "TEstratumName" - expect_equal(colnames(res)[ncol(res)], "TEstratumName") - #ecpect all values in ast column to be January|February - expect_equal(all(grepl("January|February", res$TEstratumName)), TRUE) + expect_equal(unique(res$TEstratumName), "January|February") }) @@ -55,9 +56,15 @@ test_that("Function handles intersection correctly", { res <- getLowerTableSubsets(list(TEid = 4, TEstratumName = "January"), "SA", H8ExampleEE1, T) expect_equal(nrow(res), 2) - #expect last column to be "TEstratumName" - expect_equal(colnames(res)[ncol(res)], "TEstratumName") - #expect value in last column to be "January" expect_equal(res$TEstratumName, rep("January",2)) }) + +test_that("Function does not duplicate the requested fields in the result", { + res <- getLowerTableSubsets(list(TEid = 4, TEstratumName = "January"), "SA", H8ExampleEE1, T) + + expect_equal(anyDuplicated(colnames(res)), 0) + expect_equal(sum(colnames(res) == "TEstratumName"), 1) + expect_equal(sum(colnames(res) == "TEid"), 1) +}) +}) \ No newline at end of file diff --git a/tests/testthat/test-importRDBESDataCSV.R b/tests/testthat/test-importRDBESDataCSV.R index d3b6ea46..658c8e31 100644 --- a/tests/testthat/test-importRDBESDataCSV.R +++ b/tests/testthat/test-importRDBESDataCSV.R @@ -1,8 +1,7 @@ +# AI-assisted: No +# Review: rix133 capture.output({ ## suppresses printing of console output when running test() - - - # common parameters # H1 directory dirH1 <- "./h1_v_20250211/" @@ -81,8 +80,15 @@ capture.output({ ## suppresses printing of console output when running test() file.remove(tempBVfNname) expect_equal(BV$BVfishId[1],id) }) - - +test_that("Importing a CSV folder with an id above 2,147,483,647 works",{ + expect_error(importRDBESDataCSV(rdbesExtractPath = "./bigid"), NA) +}) + +test_that("id columns without large values are still integers and with are doubles",{ + res <- importRDBESDataCSV(rdbesExtractPath = "./bigid") + expect_true(is.double(res$SD$SDid)) + expect_true(is.integer(res$SD$DEid)) +}) }) ## end capture.output diff --git a/tests/testthat/test-joinDT.R b/tests/testthat/test-joinDT.R new file mode 100644 index 00000000..e71582b5 --- /dev/null +++ b/tests/testthat/test-joinDT.R @@ -0,0 +1,195 @@ +capture.output({ ## suppresses printing of console output when running test() + + +# Make a data.frame and a data.table holding the same columns use as +# x <- makeDFandDT(id = c(3L, 1L, 2L), a = c("x3", "x1", "x2")) +makeDFandDT <- function(...) { + df <- data.frame(...) + list(df = df, dt = data.table::as.data.table(df)) +} + + +# AI-assisted: No +# Human review: rix133 +# Notes/scope: Expected results written by hand from the dplyr join conventions. +test_that("joinDT left join keeps all x rows in x order with y matches in y order", { + x <- makeDFandDT(id = c(3L, 1L, 2L), a = c("x3", "x1", "x2")) + y <- makeDFandDT(id = c(1L, 3L, 1L), b = c("y1a", "y3", "y1b")) + + res <- joinDT(x$dt, y$dt, by = "id") + + expected <- data.table::data.table(id = c(3L, 1L, 1L, 2L), + a = c("x3", "x1", "x1", "x2"), + b = c("y3", "y1a", "y1b", NA)) + expect_equal(res, expected) + + # Manual comparison code: + # joinDT(x$df, y$df, by = "id") + # dplyr::left_join(x$df, y$df, by = "id") +}) + +# AI-assisted: No +# Human review: rix133 +# Notes/scope: Expected results written by hand from the dplyr join conventions. +test_that("joinDT inner join drops the rows without a match", { + x <- makeDFandDT(id = c(3L, 1L, 2L), a = c("x3", "x1", "x2")) + y <- makeDFandDT(id = c(1L, 3L, 4L), b = c("y1", "y3", "y4")) + + res <- joinDT(x$dt, y$dt, by = "id", type = "inner") + + expected <- data.table::data.table(id = c(3L, 1L), + a = c("x3", "x1"), + b = c("y3", "y1")) + expect_equal(res, expected) + + # Manual comparison code: + # joinDT(x$df, y$df, by = "id", type = "inner") + # dplyr::inner_join(x$df, y$df, by = "id") +}) + +# AI-assisted: No +# Human review: rix133 +# Notes/scope: Expected results written by hand from the dplyr join conventions. +test_that("joinDT right join appends the unmatched y rows at the end", { + x <- makeDFandDT(id = c(1L, 2L, 5L), a = c("x1", "x2", "x5")) + y <- makeDFandDT(id = c(4L, 2L, 1L), b = c("y4", "y2", "y1")) + + res <- joinDT(x$dt, y$dt, by = "id", type = "right") + + expected <- data.table::data.table(id = c(1L, 2L, 4L), + a = c("x1", "x2", NA), + b = c("y1", "y2", "y4")) + expect_equal(res, expected) + + # Manual comparison code: + # joinDT(x$df, y$df, by = "id", type = "right") + # dplyr::right_join(x$df, y$df, by = "id") +}) + +# AI-assisted: Yes +# Human review: rix133 +# Notes/scope: Expected results written by hand from the dplyr join conventions. +test_that("joinDT joins on differently named keys and adds suffixes to shared columns", { + x <- makeDFandDT(k = c(1L, 2L), v = c("x1", "x2")) + y <- makeDFandDT(key = c(2L, 1L), v = c("y2", "y1")) + + res <- joinDT(x$df, y$df, by = c("k" = "key")) + expect_false(data.table::is.data.table(res)) + expect_equal(res, data.frame(k = c(1L, 2L), + v.x = c("x1", "x2"), + v.y = c("y1", "y2"))) + + res2 <- joinDT(x$df, y$df, by = c("k" = "key"), suffix = c("", ".y")) + expect_equal(names(res2), c("k", "v", "v.y")) + + # Manual comparison code: + # joinDT(x$df, y$df, by = c("k" = "key")) + # dplyr::left_join(x$df, y$df, by = c("k" = "key")) + # joinDT(x$df, y$df, by = c("k" = "key"), suffix = c("", ".y")) + # dplyr::left_join(x$df, y$df, by = c("k" = "key"), suffix = c("", ".y")) +}) + +# AI-assisted: No +# Human review: rix133 +# Notes/scope: Expected results written by hand from the dplyr join conventions. +test_that("joinDT matches NA keys and returns all many-to-many combinations", { + x <- makeDFandDT(id = c(NA, 1L, 1L), a = c(1L, 2L, 3L)) + y <- makeDFandDT(id = c(1L, NA, 1L), b = c(10L, 20L, 30L)) + + res <- joinDT(x$dt, y$dt, by = "id", type = "inner") + + expected <- data.table::data.table(id = c(NA, 1L, 1L, 1L, 1L), + a = c(1L, 2L, 2L, 3L, 3L), + b = c(20L, 10L, 30L, 10L, 30L)) + expect_equal(res, expected) + + # Manual comparison code: + # joinDT(x$df, y$df, by = "id", type = "inner") + # dplyr::inner_join(x$df, y$df, by = "id", relationship = "many-to-many") +}) + +# AI-assisted: Yes +# Human review: rix133 +# Notes/scope: Expected results written by hand from the dplyr join conventions. +test_that("joinDT uses a common key type and does not modify its inputs", { + x <- makeDFandDT(id = c(1L, 2L), a = c("p", "q")) + y <- makeDFandDT(id = c(2, 3), b = c("r", "s")) + xBefore <- data.table::copy(x$dt) + yBefore <- data.table::copy(y$dt) + + res <- joinDT(x$dt, y$dt, by = "id") + + expect_type(res$id, "double") + expect_equal(res$b, c(NA, "r")) + expect_equal(x$dt, xBefore) + expect_equal(y$dt, yBefore) + + # Manual comparison code: + # joinDT(x$df, y$df, by = "id") + # dplyr::left_join(x$df, y$df, by = "id") +}) + +# AI-assisted: Yes +# Human review: rix133 +# Notes/scope: ids above the integer limit (2147483647) are stored as double by +# as.integer.or.dbl(); expected results written by hand. +test_that("joinDT matches large double ids exactly", { + x <- makeDFandDT(id = c(3000000001, 2147483648, 5), a = c("x1", "x2", "x3")) + y <- makeDFandDT(id = c(2147483648, 3000000002, 3000000001), + b = c("y2", "yNear", "y1")) + + res <- joinDT(x$dt, y$dt, by = "id") + + expect_identical(res$id, c(3000000001, 2147483648, 5)) + expect_equal(res$b, c("y1", "y2", NA)) + + # Manual comparison code: + # joinDT(x$df, y$df, by = "id") + # dplyr::left_join(x$df, y$df, by = "id") +}) + +# AI-assisted: Yes +# Human review: rix133 +# Notes/scope: e.g. SA$SAid is double while FM$SAid is integer; expected +# results written by hand. +test_that("joinDT keeps a double key when joining double and integer ids", { + # large double x ids must not be turned into integer (they would become NA) + x <- makeDFandDT(id = c(3000000001, 5), a = c("x1", "x2")) + y <- makeDFandDT(id = c(5L, 6L), b = c("y5", "y6")) + res <- joinDT(x$dt, y$dt, by = "id") + expect_identical(res$id, c(3000000001, 5)) + expect_equal(res$b, c(NA, "y5")) + + # small double x ids stay double too + x2 <- makeDFandDT(id = c(1, 5), a = c("x1", "x2")) + res2 <- joinDT(x2$dt, y$dt, by = "id") + expect_identical(res2$id, c(1, 5)) + + # unmatched large y ids are kept in a right join + res3 <- joinDT(y$dt, x$dt, by = "id", type = "right") + expect_identical(res3$id, c(5, 3000000001)) + expect_equal(res3$b, c("y5", NA)) + + # Manual comparison code: + # joinDT(x$df, y$df, by = "id") + # dplyr::left_join(x$df, y$df, by = "id") + # joinDT(x2$df, y$df, by = "id") + # dplyr::left_join(x2$df, y$df, by = "id") + # joinDT(y$df, x$df, by = "id", type = "right") + # dplyr::right_join(y$df, x$df, by = "id") +}) + +# AI-assisted: Yes +# Human review: rix133 +test_that("joinDT gives an error for missing or incompatible key columns", { + expect_error(joinDT(data.table::data.table(id = 1L), + data.table::data.table(id = "1"), + by = "id"), + "Incompatible join types") + expect_error(joinDT(data.table::data.table(id = 1L), + data.table::data.table(other = 1L), + by = "id"), + "missing from y") +}) + +}) diff --git a/tests/testthat/test-lowerTblData.R b/tests/testthat/test-lowerTblData.R index cd29eee9..f2c73d5a 100644 --- a/tests/testthat/test-lowerTblData.R +++ b/tests/testthat/test-lowerTblData.R @@ -1,3 +1,7 @@ +# AI-assisted: Yes +# Review: rix133 +capture.output({ ## suppresses printing of console output when running test() + # Define some mock data for testing DE <- data.table(DEid = c(1, 2, 3, 4)) SD <- data.table(SDid = c(1, 2, 3, 4), DEid = c(1, 2, 3, 4)) @@ -12,21 +16,21 @@ test_that("Function returns correct data for valid inputs", { result <- lowerTblData("TEid", c(1), tblsSprat, "LE", FALSE) expected <- data.table(TEid = 1, VSid = 1, LEid=1, value = 10) - expect_equal(result, expected) + expect_equal(result[, names(expected), with = FALSE], expected) }) test_that("Function handles multiple values correctly", { result <- lowerTblData("TEid", c(1, 4), tblsSprat, "LE", FALSE) expected <- data.table(TEid=c(1,4) ,VSid = c(1, 4),LEid=c(1,4) , value = c(10, 4)) - expect_equal(result, expected) + expect_equal(result[, names(expected), with = FALSE], expected) }) test_that("Function handles non-existent field gracefully", { result <- lowerTblData("TEid", c(99), tblsSprat, "LE", FALSE) expected <- data.table(TEid = integer(),VSid = integer(), LEid=integer() , value = integer()) - expect_equal(result, expected) + expect_equal(result[, names(expected), with = FALSE], expected) }) test_that("Function works with printLevels = TRUE", { @@ -35,9 +39,65 @@ test_that("Function works with printLevels = TRUE", { test_that("Recursive functionality works", { result <- lowerTblData("SDid", c(1), tblsSprat, "LE", FALSE) - expected <- data.table(SDid = 1, TEid = 1, VSid = 1, LEid=1, value = 10) + expected <- data.table(SDid = 1, VSid = 1, LEid = 1, value = 10) + + expect_setequal(names(result), names(expected)) + expect_equal(result[, names(expected), with = FALSE], expected) +}) + +test_that("Intermediate hierarchy ids are not added to the result", { + result <- lowerTblData("DEid", c(1), tblsSprat, "LE", FALSE) + + expect_setequal(names(result), c("DEid", names(LE))) +}) + +test_that("A non-id requested field is retained with its linked records", { + TEnamed <- data.table(TEid = c(1, 2, 3, 4), SDid = c(1, 2, 3, 4), + TEstratumName = c("Jan", "Feb", "Jan", "Mar")) + tbls <- list(DE = DE, SD = SD, TE = TEnamed, VS = VS, LE = LE) + + result <- lowerTblData("TEstratumName", c("Jan", "Feb"), tbls, "LE", FALSE) + result <- result[order(LEid)] + + expect_setequal(names(result), c("TEstratumName", names(LE))) + expect_equal(result$LEid, c(1, 2, 3)) + expect_equal(result$TEstratumName, c("Jan", "Feb", "Jan")) +}) + +test_that("Repeated requested values do not duplicate target records", { + result <- lowerTblData("TEid", c(1, 1), tblsSprat, "LE", FALSE) + + expect_equal(nrow(result), 1) +}) + +test_that("The requested value replaces an unused target field", { + result <- getLinkedDataFromLevel("LEid", 5, H8ExampleEE1, "SA") + + expect_equal(result$SAid, 5) + expect_equal(result$LEid, 5) +}) + +test_that("Same-level queries retain the target columns without duplication", { + result <- lowerTblData("VSid", c(2, 3), tblsSprat, "VS", FALSE) + + expect_setequal(names(result), names(VS)) + expect_equal(anyDuplicated(names(result)), 0) + expect_equal(result$VSid, c(2, 3)) +}) + +test_that("Empty intermediate tables are skipped", { + tbls <- list(DE = DE, SD = SD, TE = TE, VS = VS[0], LE = data.table(TEid = 1:4, LEid = 1:4)) + result <- lowerTblData("SDid", c(2), tbls, "LE", FALSE) + + expect_setequal(names(result), c("SDid", "TEid", "LEid")) + expect_equal(result$LEid, 2) +}) + +test_that("Linking fails clearly when the tables cannot be joined", { + tbls <- list(DE = DE, SD = SD, TE = TE, VS = data.table(VSid = 1:4), LE = LE) - expect_equal(result, expected) + expect_error(lowerTblData("TEid", c(1), tbls, "LE", FALSE), + "Error in linking tables TE and VS") }) # Test when lower table has no match @@ -60,3 +120,4 @@ test_that("Function works with sorted RDBESdataObjects", { test_that("Function handles invalid inputs gracefully", { expect_error(lowerTblData("invalidField", c(1), tblsSprat, "LE", FALSE)) }) +}) \ No newline at end of file diff --git a/tests/testthat/test-removeBrokenSpeciesListLinks.R b/tests/testthat/test-removeBrokenSpeciesListLinks.R index 6f1cabc3..71df6994 100644 --- a/tests/testthat/test-removeBrokenSpeciesListLinks.R +++ b/tests/testthat/test-removeBrokenSpeciesListLinks.R @@ -1,15 +1,51 @@ +# AI-assisted: Yes +# Review: rix133 +# Notes/scope: Issue #269 imported H1 data, NULL/empty SL, and a synthetic data capture.output({ ## suppresses printing of console output when running test() + # Build a synthetic H1 fixture with one valid and one broken species-list link. + # returns an RDBESDataObject with one SL record and two SS rows. + makeSpeciesListLinksFixture <- function() { + myObject <- newRDBESDataObject() + myTables <- c("DE", "SD", "VS", "FT", "FO", "SS", "SL", "IS") + # Reuse column schemas only; all fixture values are synthetic. + for (myTable in myTables) { + myObject[[myTable]] <- data.table::copy(H1Example[[myTable]][NA_integer_]) + } + + myObject$DE[, `:=`(DEid = 1L, DEhierarchy = 1L, DEyear = 2025L)] + myObject$SD[, `:=`(SDid = 1L, DEid = 1L, SDctry = "EE")] + myObject$VS[, `:=`(VSid = 1L, SDid = 1L)] + myObject$FT[, `:=`(FTid = 1L, VSid = 1L)] + myObject$FO[, `:=`(FOid = 1L, FTid = 1L)] + myObject$SS <- myObject$SS[c(1L, 1L)] + myObject$SS[, `:=`(SSid = 1:2, FOid = 1L, + SSspecListName = c("test-list", "missing-list"), + SScatchFra = "Lan")] + myObject$SL[, `:=`(SLid = 1L, SLspeclistName = "test-list", + SLcatchFrac = "Lan", SLyear = 2025L, SLcou = "EE")] + # Validation requires a non-empty IS table whenever SL is non-empty. + myObject$IS[, `:=`(ISid = 1L, SLid = 1L)] + for (myTable in myTables) { + data.table::setkeyv(myObject[[myTable]], paste0(myTable, "id")) + } + + myObject + } + test_that("removeBrokenSpeciesListLinks runs without errors - or warnings when there are no invalid species list links", { + or warnings on imported H1 data", { myPath <- "./h1_v_20250211" myH1RawObject <- importRDBESDataCSV(rdbesExtractPath = myPath) + expect_warning( + removeBrokenSpeciesListLinks(objectToCheck = myH1RawObject, + verbose = FALSE), NA) }) -test_that("removeBrokenSpeciesListLinks prduces an error +test_that("removeBrokenSpeciesListLinks produces an error if the SL table is NULL", { myPath <- "./h1_v_20250211" @@ -17,14 +53,14 @@ test_that("removeBrokenSpeciesListLinks prduces an error importRDBESDataCSV(rdbesExtractPath = myPath) myH1RawObject["SL"] <- list(NULL) - myObjectValidSpeciesListLinks <- expect_error( + expect_error( removeBrokenSpeciesListLinks(objectToCheck = myH1RawObject, verbose = FALSE) ,"The SL entry in in objectToCheck is null - cannot check for broken species list links") }) -test_that("removeBrokenSpeciesListLinks runs without errors - or warnings when there are invalid species list links", { +test_that("removeBrokenSpeciesListLinks removes all SS rows + without warnings when SL is empty", { myPath <- "./h1_v_20250211" myH1RawObject <- @@ -34,10 +70,83 @@ test_that("removeBrokenSpeciesListLinks runs without errors myFilteredObject <- filterRDBESDataObject(myH1RawObject, fieldsToFilter = myFields, valuesToFilter = myValues ) + expect_equal(nrow(myFilteredObject$SL), 0L) + myExpectedObject <- data.table::copy(myFilteredObject) + myExpectedObject$SS <- myExpectedObject$SS[0] + myObjectValidSpeciesListLinks <- expect_warning( removeBrokenSpeciesListLinks(objectToCheck = myFilteredObject ,verbose = FALSE) ,NA) + expect_equal(myObjectValidSpeciesListLinks, myExpectedObject) +}) + + + +test_that("removeBrokenSpeciesListLinks keeps a valid SS row + and removes a broken species-list link", { + + myObject <- makeSpeciesListLinksFixture() + myOriginalObject <- data.table::copy(myObject) + myExpectedObject <- data.table::copy(myObject) + myExpectedObject$SS <- myExpectedObject$SS[SSid == 1L] + + myObjectValidSpeciesListLinks <- expect_warning( + removeBrokenSpeciesListLinks(objectToCheck = myObject, + verbose = FALSE), NA) + + expect_equal(myObjectValidSpeciesListLinks, myExpectedObject) + expect_equal(myObject, myOriginalObject) +}) + +test_that("removeBrokenSpeciesListLinks handles reordered SS columns", { + + myObject <- makeSpeciesListLinksFixture() + # Both rows use the same list name; the second has no matching catch fraction. + myObject$SS[SSid == 2L, `:=`(SSspecListName = "test-list", + SScatchFra = "Dis")] + data.table::setcolorder(myObject$SS, + c("SSspecListName", setdiff(names(myObject$SS), "SSspecListName"))) + + # Column order does not make the input invalid. + expect_error(validateRDBESDataObject(myObject), NA) + myExpectedObject <- data.table::copy(myObject) + myExpectedObject$SS <- myExpectedObject$SS[SSid == 1L] + + myObjectValidSpeciesListLinks <- expect_warning( + removeBrokenSpeciesListLinks(objectToCheck = myObject, + verbose = FALSE), NA) + + expect_equal(myObjectValidSpeciesListLinks, myExpectedObject) +}) + +test_that("multiple matching SL records do not duplicate or reorder SS rows", { + + myObject <- makeSpeciesListLinksFixture() + myObject$SS[SSid == 2L, SSspecListName := "test-list"] + myObject$SS <- myObject$SS[2:1] + data.table::setkeyv(myObject$SS, "SSspecListName") + myObject$SL <- myObject$SL[c(1L, 1L)] + myObject$SL[, SLid := 1:2] + data.table::setkeyv(myObject$SL, "SLid") + myOriginalObject <- data.table::copy(myObject) + + myResult <- expect_warning(removeBrokenSpeciesListLinks(myObject), NA) + + expect_equal(myResult, myOriginalObject) + expect_equal(myObject, myOriginalObject) +}) + +test_that("empty and NULL SS entries are returned unchanged", { + + myObject <- makeSpeciesListLinksFixture() + myObject$SS <- myObject$SS[0] + myResult <- expect_warning(removeBrokenSpeciesListLinks(myObject), NA) + expect_equal(myResult, myObject) + + myObject["SS"] <- list(NULL) + myResult <- expect_warning(removeBrokenSpeciesListLinks(myObject), NA) + expect_equal(myResult, myObject) }) }) ## end capture.output diff --git a/tests/testthat/test-upperTblData.R b/tests/testthat/test-upperTblData.R index 00a62a86..a042f676 100644 --- a/tests/testthat/test-upperTblData.R +++ b/tests/testthat/test-upperTblData.R @@ -1,12 +1,17 @@ +# AI-assisted: Yes +# Review: rix133 +capture.output({ ## suppresses printing of console output when running test() + + DE <- data.table(DEid = c(1, 2)) SD <- data.table(SDid = c(1, 2), DEid = c(1, 2)) -VS <- data.table(VSid = c(1, 2), SDid = c(1, 2), value = c(10, 20)) +VS <- data.table(VSid = c(1, 2), SDid = c(1, 2), VSvalue = c(10, 20)) tbls <- list(DE = DE, SD = SD, VS = VS) test_that("upperTblData returns correct data for VSid = 1", { result <- upperTblData("VSid", c(1), tbls, "DE") - expected <- data.table(DEid = 1) + expected <- data.table(VSid = 1, DEid = 1) expect_equal(result, expected) }) @@ -14,7 +19,7 @@ test_that("upperTblData returns correct data for VSid = 1", { test_that("upperTblData returns correct data for VSid = 2", { result <- upperTblData("VSid", c(2), tbls, "DE") - expected <- data.table(DEid = 2) + expected <- data.table(VSid = 2, DEid = 2) expect_equal(result, expected) }) @@ -22,7 +27,7 @@ test_that("upperTblData returns correct data for VSid = 2", { test_that("upperTblData handles non-existent VSid", { result <- upperTblData("VSid", c(3), tbls, "DE") - expected <- data.table(DEid = integer(0)) + expected <- data.table(VSid = integer(0), DEid = integer(0)) expect_equal(result, expected) }) @@ -31,24 +36,60 @@ test_that("upperTblData works with RDBESDataObjects", { result <- upperTblData("SAid", c(1, 2), H8ExampleEE1, "TE") - expect_equal((nrow(result)), 1) - expect_equal((result$TEid), 1) + expect_equal(nrow(result), 2) + expect_equal(result$SAid, c(1, 2)) + expect_equal(result$TEid, c(1, 1)) }) test_that("upperTblData works with sorted RDBESDataObjects", { result <- upperTblData("SAid", c(1, 2), sort(H8ExampleEE1), "DE") - expect_equal((nrow(result)), 1) - expect_equal((result$DEid), 1) + expect_equal(nrow(result), 2) + expect_equal(result$SAid, c(1, 2)) + expect_equal(result$DEid, c(1, 1)) }) -test_that("upperTblData throws error for incorrect tbls type", { - expect_error(upperTblData("VSid", c(1), list(DE = 1, SD = 2, VS = 3), "DE"), "object 'VSid' not found") -}) test_that("upperTblData throws error for incorrect level", { - expect_error(upperTblData("VSid", c(1), tbls, "XX"), "XX must be a character string in the names of the tables") + expect_error(upperTblData("VSid", c(1), tbls, "XX"), "Missing table in data: XX") }) +test_that("upperTblData has the in about the several rows requested also in the result", { + + result <- upperTblData("VSvalue", c(10,20), tbls, "DE") + expected <- data.table(VSvalue = c(10,20), DEid = c(1,2)) + + expect_equal(result, expected) +}) + +test_that("upperTblData keeps different requested values that share a target record", { + + SD2 <- data.table(SDid = c(1, 2), DEid = c(1, 1)) + tbls2 <- list(DE = DE, SD = SD2, VS = VS) + + result <- upperTblData("VSid", c(1, 2), tbls2, "DE") + + expect_setequal(names(result), c("VSid", "DEid")) + expect_equal(result[, .(VSid, DEid)], data.table(VSid = c(1, 2), DEid = c(1, 1))) +}) + +test_that("upperTblData collapses repeated paths between a requested value and a target record", { + + VS2 <- data.table(VSid = c(1, 2), SDid = c(1, 1), VSvalue = c(10, 10)) + tbls2 <- list(DE = DE, SD = SD, VS = VS2) + + result <- upperTblData("VSvalue", c(10), tbls2, "DE") + + expect_equal(result[, .(VSvalue, DEid)], data.table(VSvalue = 10, DEid = 1)) +}) + +test_that("upperTblData keeps the requested value when the target field is unused", { + tbls2 <- list(DE = data.table(DEid = 1, VSid = NA_real_), SD = SD, VS = VS) + result <- upperTblData("VSid", 1, tbls2, "DE") + + expect_equal(result$DEid, 1) + expect_equal(result$VSid, 1) +}) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index fdf317a9..15b85991 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -49,4 +49,37 @@ test_that("as.integer.or.dbl successfully converts columns with large values to }) +# extractHigherFields ----------------------------------------------------- + +# Small H1 path DE-SD-VS-FT-FO-SS; SS 53 links to FO 42 whose FTid 99 does not exist +makeH1Path <- function() { + list(DE = data.table::data.table(DEid = c(1L, 2L), DEhierarchy = 1L, DEyear = c(2020L, 2021L)), + SD = data.table::data.table(SDid = c(10L, 11L), DEid = c(1L, 2L), SDctry = c("EE", "LV")), + VS = data.table::data.table(VSid = c(20L, 21L), SDid = c(10L, 11L)), + FT = data.table::data.table(FTid = c(30L, 31L), VSid = c(20L, 21L)), + FO = data.table::data.table(FOid = c(40L, 41L, 42L), FTid = c(31L, 30L, 99L)), + SS = data.table::data.table(SSid = c(50L, 51L, 52L, 53L), FOid = c(41L, 40L, 40L, 42L))) +} + +# AI-assisted: Yes +# Human review: rix133 +# Notes/scope: Expected values traced by hand through the ids in makeH1Path(). +test_that("extractHigherFields returns one value per SS row and NA for broken links", { + obj <- makeH1Path() + + expect_equal(extractHigherFields(obj, "SS", "DEyear"), c(2020L, 2021L, 2021L, NA)) + expect_equal(extractHigherFields(obj, "SS", "SDctry"), c("EE", "LV", "LV", NA)) +}) + +# AI-assisted: Yes +# Human review: rix133 +test_that("extractHigherFields gives an error for duplicated ids or a missing field", { + obj <- makeH1Path() + expect_error(extractHigherFields(obj, "SS", "XXyear"), "'field' not found") + + obj$FT <- data.table::data.table(FTid = c(30L, 30L), VSid = c(20L, 21L)) + expect_error(extractHigherFields(obj, "SS", "DEyear"), "Duplicated FTid") +}) + + }) ## end capture.output diff --git a/vignettes/v01a-data-import.Rmd b/vignettes/v01a-data-import.Rmd index 2e644549..5d1d2042 100644 --- a/vignettes/v01a-data-import.Rmd +++ b/vignettes/v01a-data-import.Rmd @@ -31,13 +31,38 @@ library(RDBEScore) dataDir <- "./yourDataDirectory/" #for demonstration purposes we will use the example data included in the package +#for downloading actual data see the section below dataDir <- paste0(system.file("extdata", package = "RDBEScore"), "/") ``` + +## Downloading data from the RDBES + +The data can be downloaded from the [RDBES web site](https://rdbes.ices.dk/#/), or from R with the [icesRDBES](https://ices-tools-prod.r-universe.dev/icesRDBES) package. icesRDBES is not on CRAN; install it from the ICES repository: + +```{r, eval = FALSE} +install.packages("icesRDBES", + repos = c("https://ices-tools-prod.r-universe.dev", + "https://cloud.r-project.org")) +``` + +The download needs access to the RDBES see the [icesRDBES](https://ices-tools-prod.r-universe.dev/icesRDBES/) documentation. For example, the CS data of hierarchy 1 for the test country ZW in 1965, as a `.zip` file with one `.csv` file per table: + +```{r, eval = FALSE} +payload <- list(dataType = "CS", + format = "CsvFilePerTable", + hierarchies = list("H1"), + csFilters = list(deYear = list("1965"), + sdCountry = list("ZW"))) +zipFile <- icesRDBES::rdbes_download_data(payload, dest_dir = dataDir) +``` + +After downloading, the file can be imported as shown below. + ## Importing zipped files -It can directly import the `.zip` archive from the RDBES download containing all mandatory hierarchy tables plus VD and SL: +RDBEScore package can directly import the `.zip` archive from the offial RDBES download containing all mandatory hierarchy tables plus VD and SL: ```{r} importedH1 <- createRDBESDataObject(input = paste0(dataDir,"H1_Example.zip")) diff --git a/vignettes/v01b-manipulating-rdbesdataobjects.Rmd b/vignettes/v01b-manipulating-rdbesdataobjects.Rmd index 457f81b6..1989abc2 100644 --- a/vignettes/v01b-manipulating-rdbesdataobjects.Rmd +++ b/vignettes/v01b-manipulating-rdbesdataobjects.Rmd @@ -230,6 +230,8 @@ validateRDBESDataObject(myFilteredObjectValidSpeciesLinks, verbose = FALSE) Sometimes it we want to see how a field or values in the **RDBESDataObject** are connected to other tables. One use case would be e.g. to see when a specific Landing Event (LE) occured.For this we can use the **getLinkedDataFromLevel()** function. +The result contains the requested field and all columns of the target table, without adding intermediate hierarchy ids. Each row links a requested value to a target record. Different requested values linked to the same record are retained. This applies in both directions and to queries within the same table; column order is not guaranteed. + ```{r} #get the TE table corresponding to the first LEid in the H8ExampleEE1 object getLinkedDataFromLevel("LEid", c(1), H8ExampleEE1, "TE", verbose = TRUE) @@ -237,7 +239,7 @@ getLinkedDataFromLevel("LEid", c(1), H8ExampleEE1, "TE", verbose = TRUE) Similarly we can get the subset of the LE table corresponding to a specific value in the TE table. This does not have to be the *id* field, but can be any field in the table. ```{r} -#get the TE table corresponding to the first LEid in the H8ExampleEE1 object +#get the LE table corresponding to the TEstratumName "November" in the H8ExampleEE1 object getLinkedDataFromLevel("TEstratumName", c("November"), H8ExampleEE1, "LE", verbose = TRUE) ``` Several values can be used to get a subset of the table. diff --git a/vignettes/v02a-generating-probabilities.Rmd b/vignettes/v02a-generating-probabilities.Rmd index df991b65..b9e56b42 100644 --- a/vignettes/v02a-generating-probabilities.Rmd +++ b/vignettes/v02a-generating-probabilities.Rmd @@ -46,11 +46,11 @@ The functions that generate probabilities do not yet deal with lower hierarchies ```{r} # Temp fixes to change data to lower hierarchy C - function won't deal with A, or B yet -myH1DataObject[["BV"]] <- dplyr::distinct(myH1DataObject[["BV"]], FMid, .keep_all = TRUE) -temp <- dplyr::left_join(myH1DataObject[["BV"]][,c("BVid","FMid")], - myH1DataObject[["FM"]][,c("FMid","SAid")], - by="FMid") -myH1DataObject[["BV"]]$SAid <- temp$SAid +# keep the first BV row of each FMid +myH1DataObject[["BV"]] <- unique(myH1DataObject[["BV"]], by = "FMid") +# link BV directly to SA using the SAid of its FM row +myH1DataObject[["BV"]]$SAid <- myH1DataObject[["FM"]]$SAid[ + match(myH1DataObject[["BV"]]$FMid, myH1DataObject[["FM"]]$FMid)] myH1DataObject[["BV"]]$FMid <- NA myH1DataObject[["SA"]]$SAlowHierarchy <- "C" myH1DataObject[["BV"]]$BVnumTotal <- 10 diff --git a/vignettes/v02b-Generating-zeros-for-species-not-observed.Rmd b/vignettes/v02b-Generating-zeros-for-species-not-observed.Rmd index d236f233..ac50453f 100644 --- a/vignettes/v02b-Generating-zeros-for-species-not-observed.Rmd +++ b/vignettes/v02b-Generating-zeros-for-species-not-observed.Rmd @@ -29,12 +29,12 @@ library(data.table) ## Load and validate example data ```{r} -# read an example dataset and simplify it to 1 trip and 1 haul [dev bote: this section needs to be reworked when data and filterRDBESDataObject are updated] +# read an example dataset and simplify it to 1 trip and 1 haul (the first one in the dataset is selected +the dat) data(Pckg_survey_apistrat_H1) myH1DataObject1 <- Pckg_survey_apistrat_H1 myH1DataObject1$SL<-myH1DataObject1$SL[grepl(myH1DataObject1$SL$SLspeclistName, pat="Pckg_survey_apistrat_H1"),] -#myH1DataObject1<-filterAndTidyRDBESDataObject(myH1DataObject1, fieldsToFilter="FOid",valuesToFilter=70849, killOrphans = TRUE) -myH1DataObject1<-filterRDBESDataObject(myH1DataObject1, fieldsToFilter="SSid",valuesToFilter=227694, killOrphans = TRUE) +myH1DataObject1<-filterAndTidyRDBESDataObject(myH1DataObject1, fieldsToFilter="FOid",valuesToFilter=myH1DataObject1$FO$FOid[1]) # check it is a valid RDBESobject validateRDBESDataObject(myH1DataObject1) ``` diff --git a/vignettes/v02c-Generating-NAs-for-species-not-targeted-by-sampling.Rmd b/vignettes/v02c-Generating-NAs-for-species-not-targeted-by-sampling.Rmd index a0a063f6..afa3e8a3 100644 --- a/vignettes/v02c-Generating-NAs-for-species-not-targeted-by-sampling.Rmd +++ b/vignettes/v02c-Generating-NAs-for-species-not-targeted-by-sampling.Rmd @@ -33,7 +33,7 @@ data(Pckg_survey_apistrat_H1) myH1DataObject1 <- Pckg_survey_apistrat_H1 myH1DataObject1$SL<-myH1DataObject1$SL[grepl(myH1DataObject1$SL$SLspeclistName, pat="Pckg_survey_apistrat_H1"),] #myH1DataObject1<-filterAndTidyRDBESDataObject(myH1DataObject1, fieldsToFilter="FOid",valuesToFilter=70849, killOrphans = TRUE) -myH1DataObject1<-filterRDBESDataObject(myH1DataObject1, fieldsToFilter="SSid",valuesToFilter=227694, killOrphans = TRUE) +myH1DataObject1<-filterRDBESDataObject(myH1DataObject1, fieldsToFilter="SSid",valuesToFilter=myH1DataObject1$SS$SSid[1], killOrphans = TRUE) # check it is a valid RDBESobject validateRDBESDataObject(myH1DataObject1) ``` diff --git a/vignettes/v03b-Estimating-population-parameters-ratio-estimator.Rmd b/vignettes/v03b-Estimating-population-parameters-ratio-estimator.Rmd index 3751f025..e10b3020 100644 --- a/vignettes/v03b-Estimating-population-parameters-ratio-estimator.Rmd +++ b/vignettes/v03b-Estimating-population-parameters-ratio-estimator.Rmd @@ -128,11 +128,64 @@ ageCANUM <- doBVestimCANUM(biolCL, addCols, verbose = FALSE) ageCANUM - ``` +## Exporting results to InterCatch -The output table should be enough to populate a classic Intercatch data call table. +The results can be formatted for the InterCatch data call using **exportEstimationResultsToInterCatchFormat()**. +To do this we need to map the columns in our calculated `ageCANUM` object to the column names expected by the export function. + +```{r} +# Map the results to InterCatch format +dataToExport <- data.frame( + # HI columns + Country = "EE", + Year = "2022", + SeasonType = "Quarter", + Season = ageCANUM$CLquar, + Fleet = ageCANUM$CLmetier6, + AreaType = "Div", + FishingArea = ageCANUM$CLarea, + DepthRange = "NA", + + # SI columns + Species = ageCANUM$SAspeCodeFAO, + Stock = "Unknown", + CatchCategory = "L", + ReportingCategory = "R", + DataToFrom = "Data", + Usage = "Used", + SamplesOrigin = "U", + QualityFlag = "U", + UnitCATON = "kg", + CATON = ageCANUM$sumCLoffWeight, + OffLandings = ageCANUM$sumCLoffWeight, + + # SD columns + Sex = "N", + CANUMtype = "L", + AgeLength = as.integer(as.character(ageCANUM$Group)), + PlusGroup = ageCANUM$plusGroup, + #SampledCatch = ageCANUM$sumCLoffWeight, + #NumSamplesLngt = ageCANUM$lenMeas, + #NumLngtMeas = ageCANUM$lenMeas, + #NumSamplesAge = ageCANUM$lenMeas, + #NumAgeMeas = ageCANUM$lenMeas, + unitMeanWeight = "g", + unitCANUM = "n", + UnitAgeOrLength = "Age", + UnitMeanLength = "mm", + NumberCaught = ageCANUM$totNum, + MeanWeight = ageCANUM$WeightgMean, + MeanLength = ageCANUM$LengthmmMean +) + +# Generate the InterCatch string +ic_output <- exportEstimationResultsToInterCatchFormat(dataToExport) + +# Show the first few lines of the output +head(ic_output) +``` See also other package vignettes: