Added verbose parameter (issue #200)

R/applyGenerateProbs.R

@@ -12,6 +12,8 @@
 #' @param overwrite - if TRUE will overwrite probabilities already existing for
 #' SRSWR and SRSWOR
 #' @param runInitialProbChecks - if TRUE runs runChecksOnSelectionAndProbs
+#' @param verbose (Optional) Set to TRUE if you want informative text printed
+#' out, or FALSE if you don't.  The default is FALSE.
 #' @param strict (Optional) This function validates its input data - should
 #' the validation be strict? The default is TRUE.
 #'
@@ -27,10 +29,11 @@
 
 applyGenerateProbs <- function(x, probType, overwrite,
                                runInitialProbChecks = TRUE,
+                               verbose = FALSE,
                                strict = TRUE) {
 
   # Check we have a valid RDBESDataObject before doing anything else
-  validateRDBESDataObject(x, verbose = FALSE, strict = strict)
+  validateRDBESDataObject(x, verbose = verbose, strict = strict)
 
   if (runInitialProbChecks) {
     print("========start runChecksOnSelectionAndProbs=======")

R/combineRDBESDataObjects.R

@@ -4,6 +4,8 @@
 #'
 #' @param RDBESDataObject1 The first object to combine
 #' @param RDBESDataObject2 The second object to combine
+#' @param verbose (Optional) Set to TRUE if you want informative text printed
+#' out, or FALSE if you don't.  The default is FALSE.
 #' @param strict (Optional) This function validates its input data - should
 #' the validation be strict? The default is TRUE.
 #'
@@ -24,9 +26,11 @@
 #' }
 combineRDBESDataObjects <- function(RDBESDataObject1,
                                     RDBESDataObject2,
+                                    verbose = FALSE,
                                     strict = TRUE) {
-  validateRDBESDataObject(RDBESDataObject1, verbose = FALSE, strict = strict)
-  validateRDBESDataObject(RDBESDataObject2, verbose = FALSE, strict = strict)
+
+  validateRDBESDataObject(RDBESDataObject1, verbose = verbose, strict = strict)
+  validateRDBESDataObject(RDBESDataObject2, verbose = verbose, strict = strict)
   # Create an empty RDBESDataObject as the basis of what we will return
   myRDBESDataObject <- createRDBESDataObject()
 

R/createRDBESDataObject.R

@@ -53,6 +53,8 @@
 #'   attempt to cast the required columns to the correct data type.  If `FALSE`
 #'   then the column data types will be determined by how the csv files are read
 #'   in. Default is `TRUE`.
+#' @param verbose (Optional) Set to TRUE if you want informative text printed
+#'  out, or FALSE if you don't.  The default is FALSE.
 #' @param ... parameters passed to validateRDBESDataObject
 #' if input is list of data frames e.g.`strict=FALSE`
 #' @importFrom utils file_test
@@ -67,6 +69,7 @@
 createRDBESDataObject <- function(input = NULL,
                                   listOfFileNames = NULL,
                                   castToCorrectDataTypes = TRUE,
+                                  verbose = FALSE,
                                   ...) {
 
   # Classify input type
@@ -98,7 +101,10 @@ createRDBESDataObject <- function(input = NULL,
 
   if(import.type == "list.of.dfs") {
     warning("NOTE: Creating RDBES data objects from a list of local data frames bypasses the RDBES upload data integrity checks.\n")
-    output <- importRDBESDataDFS(myList = input, castToCorrectDataTypes = castToCorrectDataTypes, ...)
+    output <- importRDBESDataDFS(myList = input,
+                                 castToCorrectDataTypes = castToCorrectDataTypes,
+                                 verbose = verbose,
+                                 ...)
   }
 
   if(import.type == "null") {

R/estim.R

@@ -8,6 +8,8 @@
 #' parameters y and enk
 #' @param varFunction the function to use to estimate variance given
 #' parameters y,enk and enkl
+#' @param verbose (Optional) Set to TRUE if you want informative text printed
+#' out, or FALSE if you don't.  The default is FALSE.
 #'
 #' @return list of 7 elements including the population mean, total
 #' (and their variance), the algorithm name used and the I order
@@ -16,14 +18,28 @@
 #'
 #' @examples
 #' estimMC(c(3, 4, 4, 5), c(4, 4, 4, 4), c(8, 8, 8, 8))
-estim <- function(y, enk, enkl, method = "SRSWOR",estFunction,varFunction) {
+estim <- function(y,
+                  enk,
+                  enkl,
+                  method = "SRSWOR",
+                  estFunction,
+                  varFunction,
+                  verbose = FALSE) {
 
   n <- length(y)
 
+  if (verbose){
+    print("Esimating total using user-supplied function")
+  }
+
   # Total
   est.algorithm <- "User supplied"
   est.total <- estFunction(y,enk)
 
+  if (verbose){
+    print("Esimating variance using user-supplied function")
+  }
+
   # Variance
   var.algorithm <- "User supplied"
   var.total <- varFunction(y,enk,enkl)

R/estimMC.R

@@ -6,6 +6,8 @@
 #' @param method character selection method code e.g SRSWOR
 #' @param selProb the selection probabilities (if known)
 #' @param incProb the inclusion probabilities (if known)
+#' @param verbose (Optional) Set to TRUE if you want informative text printed
+#' out, or FALSE if you don't.  The default is FALSE.
 #'
 #' @return list of 7 elements including the population mean, total
 #' (and their variance), the algorithm name used and the I order
@@ -15,7 +17,7 @@
 #' @examples
 #' estimMC(c(3, 4, 4, 5), c(4, 4, 4, 4), c(8, 8, 8, 8))
 estimMC <- function(y, sampled, total, method = "SRSWOR", selProb = NULL,
-                    incProb = NULL) {
+                    incProb = NULL, verbose = FALSE) {
   implementedMethods <- c(
     "^SRSWR$",
     "^SRSWOR$",
@@ -82,12 +84,20 @@ estimMC <- function(y, sampled, total, method = "SRSWOR", selProb = NULL,
     }
   }
 
+  if (verbose){
+    print("Esimating total using Generalized Horvitz-Thompson aka Mutiple-Count")
+  }
+
   # Generalized Horvitz-Thompson estimator
   est.algorithm <- "Generalized Horvitz-Thompson aka Mutiple-Count"
   estFunction <- function(y,enk){
     sum(y / enk)
   }
 
+  if (verbose){
+    print("Esimating variance using Sen-Yates-Grundy estimate")
+  }
+
   # Sen-Yates-Grundy estimate of variance
   var.algorithm <- "Sen-Yates-Grundy"
   varFunction <- function(y,enk,enkl){

R/filterAndTidyRDBESDataObject.R

@@ -8,8 +8,10 @@
 #' @param fieldsToFilter A vector of the field names you wish to check.
 #' @param valuesToFilter A vector of the field values you wish to filter for.
 #' @param killOrphans Controls if orphan rows are removed. Default is `FALSE`.
-#' @param verboseOrphans Controls if verbose output for orphan rows is printed. Default is `FALSE`.
-#' @param verboseBrokenVesselLinks Controls if verbose output for broken vessel links is printed. Default is `FALSE`.
+#' @param verbose (Optional) Set to TRUE if you want informative text printed
+#' out, or FALSE if you don't.  The default is FALSE.
+#' @param strict (Optional) This function validates its input data - should
+#' the validation be strict? The default is TRUE.
 #'
 #' @return The filtered input object of the same class as `RDBESDataObjectToFilterAndTidy`.
 #'
@@ -37,30 +39,41 @@ filterAndTidyRDBESDataObject <- function(RDBESDataObjectToFilterAndTidy,
                                  fieldsToFilter,
                                  valuesToFilter,
                                  killOrphans = FALSE,
-                                 verboseOrphans = FALSE,
-                                 verboseBrokenVesselLinks = FALSE)
+                                 verbose = FALSE,
+                                 strict = TRUE)
   {
 
   # Check we have a valid RDBESDataObject before doing anything else
-  validateRDBESDataObject(RDBESDataObjectToFilterAndTidy, verbose = FALSE)
+  validateRDBESDataObject(RDBESDataObjectToFilterAndTidy,
+                          verbose = verbose,
+                          strict = strict)
 
   # 1 - filter
   # If now fields/values to filter, then the same object is returned; else filtering
   if (!(missing(fieldsToFilter) | missing(valuesToFilter)))
-    RDBESDataObjectToFilterAndTidy <- filterRDBESDataObject(RDBESDataObjectToFilterAndTidy,
+    RDBESDataObjectToFilterAndTidy <-
+      filterRDBESDataObject(RDBESDataObjectToFilterAndTidy,
                                                       fieldsToFilter,
-                                                      valuesToFilter)
+                                                      valuesToFilter,
+                                                      verbose = verbose,
+                                                      strict = strict)
   # 2 - remove broken vessels links, broken species links not included yet
   # note to myself
   if (any(grepl("VD", fieldsToFilter)))
     print(paste0("VD filtered by: ", fieldsToFilter[which(grepl("VD", fieldsToFilter))]))
-  RDBESDataObjectToFilterAndTidy <- removeBrokenVesselLinks(RDBESDataObjectToFilterAndTidy, verbose = verboseBrokenVesselLinks)
+    RDBESDataObjectToFilterAndTidy <-
+      removeBrokenVesselLinks(RDBESDataObjectToFilterAndTidy,
+                              verbose = verbose,
+                              strict = strict)
 
 
   # 3 - remove orphans
   # Remove orphans after filtering and removing data missed in VD
   if (killOrphans == TRUE)
-      RDBESDataObjectToFilterAndTidy <- findAndKillOrphans(RDBESDataObjectToFilterAndTidy, verbose = verboseOrphans)
+      RDBESDataObjectToFilterAndTidy <-
+      findAndKillOrphans(RDBESDataObjectToFilterAndTidy,
+                         verbose = verbose,
+                         strict = strict)
 
 
   return(RDBESDataObjectToFilterAndTidy)

R/findAndKillOrphans.R

@@ -5,7 +5,7 @@
 #'
 #' @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.
 #'

R/generateNAsUsingSL.R

@@ -18,7 +18,12 @@
 #' @examples
 #' # To be added
 
-generateNAsUsingSL<-function(RDBESDataObject, targetAphiaId, overwriteSampled=TRUE, validate = TRUE, verbose=FALSE, strict=TRUE){
+generateNAsUsingSL<-function(RDBESDataObject,
+                             targetAphiaId,
+                             overwriteSampled = TRUE,
+                             validate = TRUE,
+                             verbose = FALSE,
+                             strict = TRUE){
 
 if(validate){
   validateRDBESDataObject(RDBESDataObject,
@@ -31,8 +36,8 @@ if(validate){
 	  # we don't want to update the original version
 	  tmpSS <- data.table::copy(RDBESDataObject[["SS"]])
 	  tmpSL <- data.table::copy(fixSLids(RDBESDataObject)$SL)
-	  tmpSA <- data.table::copy(RDBESDataObject[["SA"]])	
-			
+	  tmpSA <- data.table::copy(RDBESDataObject[["SA"]])
+
 		tmpSSwithSL<-merge(tmpSS, tmpSL, by="SLid", all.x=T)
 
 		ls1 <- split(tmpSSwithSL, tmpSSwithSL$SSid)
@@ -41,18 +46,18 @@ if(validate){
 			colsToConvertToNumeric <- c("SAid", "SAseqNum")
 			rdbesSA[, (colsToConvertToNumeric) := lapply(.SD, as.double),
 				.SDcols = colsToConvertToNumeric]
-		
+
 		# determines aphias that need generation
 		aphiaNeedingGenerateNAs <- targetAphiaId1[!targetAphiaId1 %in% tmpSSwithSLrow$SLcommTaxon]
-	
+
 		if(length(aphiaNeedingGenerateNAs)>0)
 		{
 		# checks if they already exist in SA [case of the exceptional observer]
 		inSA <- aphiaNeedingGenerateNAs %in% rdbesSA[SSid == tmpSSwithSLrow$SSid,]$SAspeCode
 		if(any(!inSA))
 		# creates a new row
 		{
-		draftNewRows <- do.call("rbind", replicate(n=length(aphiaNeedingGenerateNAs[!inSA]), 
+		draftNewRows <- do.call("rbind", replicate(n=length(aphiaNeedingGenerateNAs[!inSA]),
 							rdbesSA[SSid == tmpSSwithSLrow$SSid,][1,], simplify = FALSE))
 
 		draftNewRows$SAspeCode <- aphiaNeedingGenerateNAs[!inSA]
@@ -66,22 +71,22 @@ if(validate){
 			rdbesSA <- rbind(rdbesSA, draftNewRows)
 		# checks if spp were added ok
 		#browser()
-			test_fail <- length(aphiaNeedingGenerateNAs <- targetAphiaId1[!targetAphiaId1 %in% rdbesSA$SAspeCode])>0	
+			test_fail <- length(aphiaNeedingGenerateNAs <- targetAphiaId1[!targetAphiaId1 %in% rdbesSA$SAspeCode])>0
 			if(test_fail) stop()
-		} 
-		
+		}
+
 		if(any(inSA)){
 			# if they do and overwrite==T give him/her bonus points and but overwrite their data with NAs
 			# if they do and overwrite==F give him/her bonus points and and keep their data
 			if(overwriteSampled==T) {
 				rdbesSA[SSid == tmpSSwithSLrow$SSid & SAspeCode %in% aphiaNeedingGenerateNAs,c("SAtotalWtLive",
-															"SAsampWtLive","SAtotalWtMes","SAsampWtMes")] <- NA 
+															"SAsampWtLive","SAtotalWtMes","SAsampWtMes")] <- NA
 			} else {"do nothing"}}
 		}
-		#browser()		
-		rdbesSA} 	
+		#browser()
+		rdbesSA}
 		)
 		RDBESDataObject[["SA"]] <- data.table::setDT(do.call("rbind", ls2))
 		setkey(RDBESDataObject[["SA"]],"SAid")
 		RDBESDataObject
-}	
+}

R/generateProbs.r

@@ -3,6 +3,8 @@
 #' @param x RDBES data object
 #' @param probType  "selection" or "inclusion" for selection and inclusion
 #' probabilities respectively
+#' @param verbose (Optional) Set to TRUE if you want informative text printed
+#' out, or FALSE if you don't.  The default is FALSE.
 #'
 #' @details When the selection method is SRSWR selection probabilities are
 #' calculated as \eqn{1 / N} and inclusion probabilities as
@@ -25,7 +27,9 @@
 #' generateProbs(x = Pckg_SDAResources_agstrat_H1[["VS"]], probType = ("selection"))
 #'
 #' }
-generateProbs <- function(x, probType) {
+generateProbs <- function(x,
+                          probType,
+                          verbose = FALSE) {
 
   # Only allow "inclusion" or "selection" probType at the moment
   if (!probType %in% c("inclusion", "selection")) {

R/getTablesInRDBESHierarchy.R

@@ -7,6 +7,8 @@
 #' Default value is TRUE
 #' @param includeTablesNotInSampHier Include tables that aren't
 #' sampling units in that hierarcy?  Default value is TRUE
+#' @param verbose (Optional) Set to TRUE if you want informative text printed
+#' out, or FALSE if you don't.  The default is FALSE.
 #'
 #' @return A vector containing the 2-letter names of the tables in the
 #' requested hierarchy
@@ -17,7 +19,8 @@
 getTablesInRDBESHierarchy <- function(hierarchy,
                                       includeOptTables = TRUE,
                                       includeLowHierTables = TRUE,
-                                      includeTablesNotInSampHier = TRUE) {
+                                      includeTablesNotInSampHier = TRUE,
+                                      verbose = FALSE) {
   if (!is.numeric(hierarchy)) {
     stop("hierarchy parameter must be an integer")
   }

R/importRDBESDataDFS.R

@@ -7,6 +7,8 @@
 #'   data frame with an RDBES two-letter name (e.g. "DE").
 #' @param castToCorrectDataTypes logical. Indicates whether to cast the columns
 #'   to the correct data types. Default is `TRUE`.
+#' @param verbose (Optional) Set to TRUE if you want informative text printed
+#'  out, or FALSE if you don't.  The default is FALSE.
 #' @param strict logical. Indicates level of validation of the `RDBESDataObject`
 #'   it creates - should the validation be strict? Default is `TRUE`.
 #' @param addMissingColumns logical. Indicates whether to add missing columns
@@ -38,6 +40,7 @@
 #'   `RDBEScore::validateRDBESDataObject` and returns it.
 importRDBESDataDFS <- function(myList,
                                castToCorrectDataTypes = TRUE,
+                               verbose = FALSE,
                                strict = TRUE,
                                addMissingColumns = FALSE,
                                ...){
@@ -122,6 +125,7 @@ importRDBESDataDFS <- function(myList,
   #check the data
   validateRDBESDataObject(dt,
                           checkDataTypes = castToCorrectDataTypes,
+                          verbose = verbose,
                           strict = strict,
                           ...)