Merge pull request #22 from IDEMSInternational/sub_branch

functions after checks
IDEMSInternational · Nov 20, 2024 · d1c85ae · d1c85ae
2 parents 013a275 + e58c0d8
commit d1c85ae
Show file tree

Hide file tree

Showing 8 changed files with 94 additions and 748 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -11,11 +11,15 @@ Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.2
 Imports: 
     chillR,
+    circular,
     clipr,
     data.table, 
     dplyr,
+    e1071,
     ggplot2,
     gridExtra,
+    Hmisc,
+    hydroGOF,
     lazyeval,
     lubridate,
     imputeTS,
@@ -25,10 +29,14 @@ Imports:
     plyr,
     purrr,
     R6,
-    reshape2, 
+    reshape2,
+    robustbase,
     sjlabelled,
     sjmisc,
     stringr,
     tibble,
     tidyselect,
-    zoo
+    verification,
+    Weighted.Desc.Stat,
+    weights,
+    zoo
diff --git a/LICENSE b/LICENSE
diff --git a/NAMESPACE b/NAMESPACE
@@ -24,7 +24,6 @@ export(count_calc)
 export(cp)
 export(d)
 export(get_summary_calculation_names)
-export(hss)
 export(instat_comment)
 export(link)
 export(mNSE)
@@ -47,7 +46,6 @@ export(p70)
 export(p75)
 export(p80)
 export(p90)
-export(pc)
 export(proportion_calc)
 export(pss)
 export(rNSE)

diff --git a/R/data_book.R b/R/data_book.R
@@ -245,18 +245,18 @@
 #'   \item{\code{link_between_containing(from_data_frame, containing_columns, to_data_frame)}}{This function returns columns in `to_data_frame` corresponding to `containing_columns` in `from_data_frame` if a link exists between them.}
 #'   \item{\code{view_link(link_name)}}{Displays the details of a specified link.}
 #'   
-#'   \item{\code{apply_calculation(calc)}{Apply a Calculation to Data in the DataBook}}
-#'   \item{\code{save_calculation(end_data_frame, calc)}{Save a Calculation to a Data Frame}}
-#'   \item{\code{apply_instat_calculation(calc, curr_data_list, previous_manipulations = list(), param_list = list())}{Apply an Instat Calculation}}
-#'   \item{\code{run_instat_calculation(calc, display = TRUE, param_list = list())}{Run an Instat Calculation and Display Results}}
-#'   \item{\code{get_corresponding_link_columns(first_data_frame_name, first_data_frame_columns, second_data_frame_name)}{Get Corresponding Link Columns}}
-#'   \item{\code{get_link_columns_from_data_frames(first_data_frame_name, first_data_frame_columns, second_data_frame_name, second_data_frame_columns)}{Get Link Columns Between Data Frames}}
-#'   \item{\code{save_calc_output(calc, curr_data_list, previous_manipulations)}{Save the Output of a Calculation}}
+#'   \item{\code{apply_calculation(calc)}}{Apply a Calculation to Data in the DataBook}
+#'   \item{\code{save_calculation(end_data_frame, calc)}}{Save a Calculation to a Data Frame}
+#'   \item{\code{apply_instat_calculation(calc, curr_data_list, previous_manipulations = list(), param_list = list())}}{Apply an Instat Calculation}
+#'   \item{\code{run_instat_calculation(calc, display = TRUE, param_list = list())}}{Run an Instat Calculation and Display Results}
+#'   \item{\code{get_corresponding_link_columns(first_data_frame_name, first_data_frame_columns, second_data_frame_name)}}{Get Corresponding Link Columns}
+#'   \item{\code{get_link_columns_from_data_frames(first_data_frame_name, first_data_frame_columns, second_data_frame_name, second_data_frame_columns)}}{Get Link Columns Between Data Frames}
+#'   \item{\code{save_calc_output(calc, curr_data_list, previous_manipulations)}}{Save the Output of a Calculation}
 #'   
-#'   \item{\code{append_summaries_to_data_object(out, data_name, columns_to_summarise, summaries, factors = c(), summary_name, calc, calc_name = "")}{Append Summaries to a Data Object}}
-#'   \item{\code{calculate_summary(data_name, columns_to_summarise = NULL, summaries, factors = c(), store_results = TRUE, drop = TRUE, return_output = FALSE, summary_name = NA, result_names = NULL, percentage_type = "none", perc_total_columns = NULL, perc_total_factors = c(), perc_total_filter = NULL, perc_decimal = FALSE, perc_return_all = FALSE, include_counts_with_percentage = FALSE, silent = FALSE, additional_filter, original_level = FALSE, signif_fig = 2, sep = "_", ...)}{Calculate Summaries for a Data Object}}
-#'   \item{\code{summary(data_name, columns_to_summarise, summaries, factors = c(), store_results = FALSE, drop = FALSE, return_output = FALSE, summary_name = NA, add_cols = c(), filter_names = c(), ...)}{Perform and Return Summaries for a Data Object}}
-#'   \item{\code{summary_table(data_name, columns_to_summarise = NULL, summaries, factors = c(), store_table = FALSE, store_results = FALSE, drop = TRUE, na.rm = FALSE, summary_name = NA, include_margins = FALSE, margins = "outer", return_output = FALSE, treat_columns_as_factor = FALSE, page_by = NULL, signif_fig = 2, na_display = "", na_level_display = "NA", weights = NULL, caption = NULL, result_names = NULL, percentage_type = "none", perc_total_columns = NULL, perc_total_factors = c(), perc_total_filter = NULL, perc_decimal = FALSE, include_counts_with_percentage = FALSE, margin_name = "(All)", additional_filter, ...)}{Generate a Summary Table}}
+#'   \item{\code{append_summaries_to_data_object(out, data_name, columns_to_summarise, summaries, factors = c(), summary_name, calc, calc_name = "")}}{Append Summaries to a Data Object}
+#'   \item{\code{calculate_summary(data_name, columns_to_summarise = NULL, summaries, factors = c(), store_results = TRUE, drop = TRUE, return_output = FALSE, summary_name = NA, result_names = NULL, percentage_type = "none", perc_total_columns = NULL, perc_total_factors = c(), perc_total_filter = NULL, perc_decimal = FALSE, perc_return_all = FALSE, include_counts_with_percentage = FALSE, silent = FALSE, additional_filter, original_level = FALSE, signif_fig = 2, sep = "_", ...)}}{Calculate Summaries for a Data Object}
+#'   \item{\code{summary(data_name, columns_to_summarise, summaries, factors = c(), store_results = FALSE, drop = FALSE, return_output = FALSE, summary_name = NA, add_cols = c(), filter_names = c(), ...)}}{Perform and Return Summaries for a Data Object}
+#'   \item{\code{summary_table(data_name, columns_to_summarise = NULL, summaries, factors = c(), store_table = FALSE, store_results = FALSE, drop = TRUE, na.rm = FALSE, summary_name = NA, include_margins = FALSE, margins = "outer", return_output = FALSE, treat_columns_as_factor = FALSE, page_by = NULL, signif_fig = 2, na_display = "", na_level_display = "NA", weights = NULL, caption = NULL, result_names = NULL, percentage_type = "none", perc_total_columns = NULL, perc_total_factors = c(), perc_total_filter = NULL, perc_decimal = FALSE, include_counts_with_percentage = FALSE, margin_name = "(All)", additional_filter, ...)}}{Generate a Summary Table}
 #'   
 #'   @export
 DataBook <- R6::R6Class("DataBook",
@@ -4759,8 +4759,7 @@ DataBook <- R6::R6Class("DataBook",
                           #'   `save_calculation` method to store the calculation.
                           #' - The `calc` object typically includes details such as its `name`, `type`, and any parameters 
                           #'   or dependencies required to perform the calculation.
-                          #'
-                          #' @seealso \code{\link{DataSheet$save_calculation}}
+                          #' - See also \code{\link{DataSheet$save_calculation}}
                           #'
                           #' @note This method delegates the actual saving of the calculation to the respective 
                           #'       data frame's `save_calculation` method, ensuring modularity and separation of concerns.
@@ -5064,9 +5063,9 @@ DataBook <- R6::R6Class("DataBook",
                                       warning(paste0("Type is different for ", by[[i]], " in the two data frames. Setting as numeric in both data frames."))
 
                                       # Convert factors to numeric if necessary
-                                      if (class(new_data_list[[by[[i]]]]) == "factor") {
+                                      if (inherits(class(new_data_list[[by[[i]]]]), "factor")) {
                                         new_data_list[[by[[i]]]] <- as.numeric(as.character(new_data_list[[by[[i]]]]))
-                                      } else if (class(curr_data_list[[c_data_label]][[by[[i]]]]) == "factor") {
+                                      } else if (inherits(class(curr_data_list[[c_data_label]][[by[[i]]]]), "factor")) {
                                         curr_data_list[[c_data_label]][[by[[i]]]] <- as.numeric(as.character(curr_data_list[[c_data_label]][[by[[i]]]]))
                                       } else {
                                         stop(paste0("Type is different for ", by[[i]], " in the two data frames and cannot be coerced."))

diff --git a/R/data_sheet.R b/R/data_sheet.R
@@ -187,8 +187,8 @@
 #'
 #'   \item{\code{save_calculation(calc)}}{Save a Calculation to the DataSheet.}
 #'   
-#'   \item{\code{merge_data(new_data, by = NULL, type = "left", match = "all")}{Merge New Data with Existing Data}}
-#'   \item{\code{calculate_summary(calc, ...)}{Calculate Summaries for Specified Columns}}
+#'   \item{\code{merge_data(new_data, by = NULL, type = "left", match = "all")}}{Merge New Data with Existing Data}
+#'   \item{\code{calculate_summary(calc, ...)}}{Calculate Summaries for Specified Columns}
 #' }
 #'
 #' @section Active bindings:

diff --git a/R/summary_functions.R b/R/summary_functions.R
@@ -485,7 +485,7 @@ summary_var <- function(x, na.rm = FALSE, weights = NULL, na_type = "", ...) {
   if(na.rm && na_type != "" && !na_check(x, na_type = na_type, ...)) return(NA)
   else{
     if (missing(weights) || is.null(weights)) {
-      return(var(x,na.rm = na.rm))
+      return(stats::var(x,na.rm = na.rm))
     }
     else {
       return(Hmisc::wtd.var(x, weights = weights, na.rm = na.rm))
@@ -669,9 +669,9 @@ summary_median <- function(x, na.rm = FALSE, weights = NULL, na_type = "", ...)
   else{
     if(missing(weights) || is.null(weights)) {
       if (stringr::str_detect(class(x), pattern = "ordered") || stringr::str_detect(class(x), pattern = "Date")) {
-        return(quantile(x, na.rm = na.rm, probs = 0.5, type = 1)[[1]])
+        return(stats::quantile(x, na.rm = na.rm, probs = 0.5, type = 1)[[1]])
       } else {
-        return(median(x, na.rm = na.rm))
+        return(stats::median(x, na.rm = na.rm))
       }
     } else {
       return(Hmisc::wtd.quantile(x, weights = weights, probs = 0.5, na.rm = na.rm))
@@ -698,9 +698,9 @@ summary_quantile <- function(x, na.rm = FALSE, weights = NULL, probs, na_type =
   else {
     if(missing(weights) || is.null(weights)) {
       if (stringr::str_detect(class(x), pattern = "ordered") || stringr::str_detect(class(x), pattern = "Date")) {
-        return(quantile(x, na.rm = na.rm, probs = probs, type = 1)[[1]])
+        return(stats::quantile(x, na.rm = na.rm, probs = probs, type = 1)[[1]])
       } else {
-        return(quantile(x, na.rm = na.rm, probs = probs)[[1]])
+        return(stats::quantile(x, na.rm = na.rm, probs = probs)[[1]])
       }
     }
     else {
@@ -913,7 +913,7 @@ summary_outlier_limit <- function(x, coef = 1.5, bupperlimit = TRUE, bskewedcalc
   }
   if(na.rm && na_type != "" && !na_check(x, na_type = na_type, ...)) return(NA)
   else{
-    quart <- quantile(x, na.rm = na.rm)
+    quart <- stats::quantile(x, na.rm = na.rm)
     Q1 <- quart[[2]]
     Q3 <- quart[[4]]
     IQR <- Q3 - Q1
@@ -1077,7 +1077,7 @@ summary_cor <- function(x, y, na.rm = FALSE, na_type = "", weights = NULL, metho
   if (na.rm && na_type != "" && !na_check(x, na_type = na_type, ...)) return(NA)
   else {
     if (missing(weights) || is.null(weights)) {
-      return(cor(x = x, y = y, use = cor_use, method = method))
+      return(stats::cor(x = x, y = y, use = cor_use, method = method))
     }
     else {
       weights::wtd.cor(x = x, y = y, weight = weights)[1]
@@ -1103,7 +1103,7 @@ summary_cov <- function(x, y, na.rm = FALSE, weights = NULL, na_type = "", metho
   if(na.rm && na_type != "" && !na_check(x, na_type = na_type, ...)) return(NA)
   else{
     if (missing(weights) || is.null(weights)) {
-      return(cov(x = x, y = y, use = use, method = method))
+      return(stats::cov(x = x, y = y, use = use, method = method))
     }
     if (length(weights) != length(x)) 
       stop("'x' and 'weights' must have the same length")
@@ -1245,7 +1245,7 @@ proportion_calc <- function(x, prop_test = "==", prop_value, As_percentage = FAL
       }  
     }
     else {
-      remove.na <- na.omit(x)
+      remove.na <- stats::na.omit(x)
       y <- remove.na[eval(parse(text = paste("remove.na", prop_value, sep = prop_test)))]
       if (!As_percentage){
         return(round(length(y)/length(remove.na), digits = 2))
@@ -1277,7 +1277,7 @@ count_calc <- function(x, count_test = "==", count_value, na.rm = FALSE, na_type
       return(length(x[eval(parse(text = paste("x", count_value, sep = count_test)))]))
     }
     else{
-      y <- na.omit(x)
+      y <- stats::na.omit(x)
       return(length(y[eval(parse(text = paste("y", count_value, sep = count_test)))]))
     }
   }
@@ -1298,11 +1298,11 @@ standard_error_mean <- function(x, na.rm = FALSE, na_type = "", ...){
   else{
     if (!na.rm){
       if(sum(is.na(x) > 0)) return(NA)
-      return(sd(x)/sqrt(length(x)))
+      return(stats::sd(x)/sqrt(length(x)))
     }
     else{
-      y <- na.omit(x)
-      return(sd(y)/sqrt(length(y)))
+      y <- stats::na.omit(x)
+      return(stats::sd(y)/sqrt(length(y)))
     }
   }
 }
@@ -1603,39 +1603,39 @@ VE <- function(x, y, na.rm = FALSE, na_type = "", ...){
   }
 }
 
-#' Calculate Percent Correct
-#'
-#' Computes the percent correct using the `verification::verify` function.
-#'
-#' @param x Observed values.
-#' @param y Predicted values.
-#' @param frcst.type Character. The type of forecast (e.g., "binary").
-#' @param obs.type Character. The type of observation (e.g., "binary").
-#' @param ... Additional arguments passed to `verification::verify`.
-#' @return The percent correct.
-#' @export
-pc <- function(x, y, frcst.type, obs.type, ...){
-  A <- verification::verify(obs = x, pred = y,  frcst.type = frcst.type, obs.type = obs.type)
-  return(A$pc)  
-}
-
-#' Calculate Heidke Skill Score
-#'
-#' Computes the Heidke skill score using the `verification::verify` function.
-#'
-#' @inheritParams pc
-#' @return The Heidke skill score.
-#' @export
-hss <- function(x, y, frcst.type, obs.type, ...){
-  A <- verification::verify(obs = x, pred = y,  frcst.type = frcst.type, obs.type = obs.type)
-  return(A$hss)  
-}
+# This repetition causes issue in package
+# #' Calculate Percent Correct
+# #'
+# #' Computes the percent correct using the `verification::verify` function.
+# #'
+# #' @param x Observed values.
+# #' @param y Predicted values.
+# #' @param frcst.type Character. The type of forecast (e.g., "binary").
+# #' @param obs.type Character. The type of observation (e.g., "binary").
+# #' @param ... Additional arguments passed to `verification::verify`.
+# #' @return The percent correct.
+# #' @export
+# pc <- function(x, y, frcst.type, obs.type, ...){
+#   A <- verification::verify(obs = x, pred = y,  frcst.type = frcst.type, obs.type = obs.type)
+#   return(A$pc)  
+# }
+# #' Calculate Heidke Skill Score
+# #'
+# #' Computes the Heidke skill score using the `verification::verify` function.
+# #'
+# #' @inheritParams PC
+# #' @return The Heidke skill score.
+# #' @export
+# hss <- function(x, y, frcst.type, obs.type, ...){
+#   A <- verification::verify(obs = x, pred = y,  frcst.type = frcst.type, obs.type = obs.type)
+#   return(A$hss)  
+# }
 
 #' Calculate Pierce Skill Score
 #'
 #' Computes the Pierce skill score using the `verification::verify` function.
 #'
-#' @inheritParams pc
+#' @inheritParams PC
 #' @return The Pierce skill score.
 #' @export
 pss <- function(x, y, frcst.type, obs.type, ...){
@@ -1647,7 +1647,7 @@ pss <- function(x, y, frcst.type, obs.type, ...){
 #'
 #' Computes the Gerrity score using the `verification::verify` function.
 #'
-#' @inheritParams pc
+#' @inheritParams PC
 #' @return The Gerrity score.
 #' @export
 GS <- function(x, y, frcst.type, obs.type, ...){
@@ -1659,7 +1659,7 @@ GS <- function(x, y, frcst.type, obs.type, ...){
 #'
 #' Computes the probability of detection (PODy) using the `verification::verify` function.
 #'
-#' @inheritParams pc
+#' @inheritParams PC
 #' @return The probability of detection.
 #' @export
 PODy <- function(x, y, frcst.type, obs.type, ...){
@@ -1671,7 +1671,7 @@ PODy <- function(x, y, frcst.type, obs.type, ...){
 #'
 #' Computes the threat score using the `verification::verify` function.
 #'
-#' @inheritParams pc
+#' @inheritParams PC
 #' @return The threat score.
 #' @export
 TS <- function(x, y, frcst.type, obs.type, ...){
@@ -1683,7 +1683,7 @@ TS <- function(x, y, frcst.type, obs.type, ...){
 #'
 #' Computes the equitable threat score using the `verification::verify` function.
 #'
-#' @inheritParams pc
+#' @inheritParams PC
 #' @return The equitable threat score.
 #' @export
 ETS <- function(x, y, frcst.type, obs.type, ...){
@@ -1695,7 +1695,7 @@ ETS <- function(x, y, frcst.type, obs.type, ...){
 #'
 #' Computes the false alarm ratio using the `verification::verify` function.
 #'
-#' @inheritParams pc
+#' @inheritParams PC
 #' @return The false alarm ratio.
 #' @export
 FAR <- function(x, y, frcst.type, obs.type, ...){
@@ -1707,7 +1707,7 @@ FAR <- function(x, y, frcst.type, obs.type, ...){
 #'
 #' Computes the Heidke skill score using the `verification::verify` function.
 #'
-#' @inheritParams pc
+#' @inheritParams PC
 #' @return The Heidke skill score.
 #' @export
 HSS <- function(x, y, frcst.type, obs.type, ...){
@@ -1719,7 +1719,11 @@ HSS <- function(x, y, frcst.type, obs.type, ...){
 #'
 #' Computes the percent correct using the `verification::verify` function.
 #'
-#' @inheritParams pc
+#' @param x Observed values.
+#' @param y Predicted values.
+#' @param frcst.type Character. The type of forecast (e.g., "binary").
+#' @param obs.type Character. The type of observation (e.g., "binary").
+#' @param ... Additional arguments passed to `verification::verify`.
 #' @return The percent correct.
 #' @export
 PC <- function(x, y, frcst.type, obs.type, ...){
@@ -1731,7 +1735,7 @@ PC <- function(x, y, frcst.type, obs.type, ...){
 #'
 #' Computes the bias using the `verification::verify` function.
 #'
-#' @inheritParams pc
+#' @inheritParams PC
 #' @return The bias.
 #' @export
 BIAS <- function(x, y, frcst.type, obs.type, ...){