get rid of fritools in examples

R/bw2bwi2022de.R

@@ -17,11 +17,9 @@
 #' }
 #' So we add two variables holding the diameter in millimeter and the horizontal
 #' distance in centimeter, named by the output of \cr
-#' \code{fritools::get_options(package_name =
-#' "treePlotArea")["angle_counts.dbh"]}\cr
+#' \code{getOption("treePlotArea")[["angle_counts"]][["dbh"]]}\cr
 #' and\cr
-#' \code{fritools::get_options(package_name =
-#' "treePlotArea")["angle_counts.distance"]}\cr
+#' \code{getOption("treePlotArea")[["angle_counts"]][["distance"]]}\cr
 #' respectively.
 #' @param x A tree data set, typically
 #' \code{get(data("trees", package = "treePlotArea"))}.
@@ -70,10 +68,8 @@ bw2bwi2022de <- function(x) {
 #' @export
 #' @examples
 #' trees <- get(data("trees", package = "treePlotArea"))
-#' fritools::is_valid_primary_key(trees, c("tnr", "enr", "bnr"))
 #' subset(trees, entf == 0 & bhd2 > 0 & stp == 0)
 #' angle_counts <- select_valid_angle_count_trees(trees)
-#' fritools::is_valid_primary_key(angle_counts, c("tnr", "enr", "bnr"))
 #' subset(angle_counts, entf == 0 & bhd2 > 0 & stp == 0)
 select_valid_angle_count_trees <- function(x, sample_type = "stp",
                                            tree_status = "pk") {

R/check_boundaries.R

@@ -11,8 +11,8 @@
 #' @param x A \code{\link{data.frame}} containing boundaries.
 #' It has to have columns named by the contents of
 #' either\cr
-#' \code{\link{get_defaults}("boundaries")} or \cr
-#' \code{fritools::get_options(package_name = "treePlotArea")[["boundaries"]]}.
+#' \code{\link{get_defaults}()[["boundaries"]]} or \cr
+#' \code{getOption("treePlotArea")[["boundaries"]]}.
 #' \cr
 #' Could be
 #' \code{get(data("boundaries", package = "treePlotArea"))}.

R/data.R

@@ -73,5 +73,4 @@
 #' @keywords datasets
 #' @examples
 #' boundaries <- get(data("boundaries", package = "treePlotArea"))
-#' fritools::is_valid_primary_key(boundaries, c("tnr", "enr", "rnr"))
 "boundaries"

R/f_is_success.R

+fritools_is_success <- function(x) return(!as.logical(x))

R/f_options.R

+.options <- function(name, value) {
+    # programmatically set options
+    eval(parse(text = paste("options(", name, "= value)")))
+}
+
+fritools_set_options <- function(..., package_name = .packages()[1], overwrite = TRUE) {
+    if (requireNamespace("checkmate", quietly = TRUE))
+        checkmate::qassert(overwrite, "B1")
+    option_list <- list(...)
+    if (length(option_list) == 1L && is.list(option_list))
+        option_list <- unlist(option_list, recursive = FALSE)
+    options_set <- get_options(package_name = package_name,
+                               flatten_list = FALSE)
+    if (isTRUE(overwrite)) {
+        if (is.null(options_set)) {
+            .options(package_name, option_list)
+        } else {
+            if (length(options_set) == 1L)
+                options_set <- as.list(options_set)
+            .options(package_name, utils::modifyList(options_set, option_list))
+        }
+    } else {
+        is_option_unset <- ! (names(option_list) %in% names(options_set))
+        if (any(is_option_unset))
+            .options(package_name,
+                     append(options_set, option_list[is_option_unset]))
+    }
+    return(invisible(TRUE))
+}
+
+fritools_get_options <- function(..., package_name = .packages()[1],
+                        remove_names = FALSE, flatten_list = TRUE) {
+    if (requireNamespace("checkmate", quietly = TRUE)) {
+        checkmate::qassert(remove_names, "B1")
+        checkmate::qassert(flatten_list, "B1")
+    }
+    if (missing(...)) {
+        option_list <- getOption(package_name)
+    } else {
+        option_names <- as.vector(...)
+        options_set <- getOption(package_name)
+        option_list  <- options_set[names(options_set) %in% option_names]
+    }
+    if (flatten_list) option_list <- unlist(option_list)
+    if (remove_names) names(option_list)  <- NULL
+    if (!is.null(option_list)) {
+        attr(option_list, "package") <- package_name
+    }
+    return(option_list)
+}
+
+

R/f_tapply.R

+fritools_tapply <- function(object, index, func = NULL, ..., default = NA,
+                   simplify = TRUE) {
+    func <- if (!is.null(func))
+        match.fun(func)
+    if (!is.list(index))
+        index <- list(index)
+    index <- lapply(index, as.factor)
+    num_i <- length(index)
+    if (!num_i)
+        stop("'index' is of length zero")
+    if (is.data.frame(object)) {
+        if (!all(lengths(index) == nrow(object)))
+            stop("arguments must have same length")
+    } else {
+        if (!all(lengths(index) == length(object)))
+            stop("arguments must have same length")
+    }
+    namelist <- lapply(index, levels)
+    extent <- lengths(namelist, use.names = FALSE)
+    cumextent <- cumprod(extent)
+    if (cumextent[num_i] > .Machine[["integer.max"]])
+        stop("total number of levels >= 2^31")
+    storage.mode(cumextent) <- "integer"
+    ngroup <- cumextent[num_i]
+    group <- as.integer(index[[1L]])
+    if (num_i > 1L)
+        for (i in 2L:num_i) group <- group + cumextent[i - 1L] *
+            (as.integer(index[[i]]) - 1L)
+    if (is.null(func))
+        return(group)
+    levels(group) <- as.character(seq_len(ngroup))
+    class(group) <- "factor"
+    ans <- split(object, group)
+    names(ans) <- NULL
+    idx <- as.logical(lengths(ans))
+    ans <- lapply(X = ans[idx], FUN = func, ...)
+    ansmat <- array(if (simplify && all(lengths(ans) == 1L)) {
+                        ans <- unlist(ans, recursive = FALSE, use.names = FALSE)
+                        if (!is.null(ans) && is.na(default) && is.atomic(ans))
+                            vector(typeof(ans))
+                        else
+                            default
+                   } else {
+                       vector("list", prod(extent))
+                   },
+                   dim = extent, dimnames = namelist)
+    if (length(ans)) {
+        ansmat[idx] <- ans
+    }
+    ansmat
+}

R/get_boundary_polygons.R

@@ -6,8 +6,8 @@
 #' @param boundaries A \code{\link{data.frame}} containing boundaries.
 #' It has to have columns named by the contents of
 #' either\cr
-#' \code{\link{get_defaults}("boundaries")} or \cr
-#' \code{fritools::get_options(package_name = "treePlotArea")[["boundaries"]]}.
+#' \code{\link{get_defaults}()[["boundaries"]]} or \cr
+#' \code{getOption("treePlotArea")[["boundaries"]]}\cr.
 #' \cr
 #' Could be
 #' \code{get(data("boundaries", package = "treePlotArea"))}.

R/get_correction_factors.R

@@ -96,17 +96,15 @@ get_correction_factor <- function(x, boundaries, stop_on_error = FALSE) {
 #' @param angle_counts A \code{\link{data.frame}} containing angle counts.
 #' It has to have columns named by the contents of
 #' either\cr
-#' \code{\link{get_defaults}("angle_counts")} or \cr
-#' \code{fritools::get_options(package_name = "treePlotArea",
-#'       flatten_list = FALSE )[["angle_counts"]]}.\cr
+#' \code{\link{get_defaults}()[["angle_counts"]]} or \cr
+#' \code{getOption("treePlotArea")[["angle_counts"]]}.\cr
 #' Could be
 #' \code{bw2bwi2022de(get(data("trees", package = "treePlotArea")))}).
 #' @param boundaries A \code{\link{data.frame}} containing boundaries.
 #' It has to have columns named by the contents of
 #' either\cr
-#' \code{\link{get_defaults}("boundaries"} or \cr
-#' \code{fritools::get_options(package_name = "treePlotArea",
-#'       flatten_list = FALSE )[["boundaries"]]}.\cr
+#' \code{\link{get_defaults}()[["boundaries"]]} or \cr
+#' \code{getOption("treePlotArea")[["boundaries"]]}.\cr
 #' Could be
 #' \code{get(data("boundaries", package = "treePlotArea"))} or the
 #' output of

R/options.R

@@ -55,15 +55,14 @@ get_defaults <- function() {
 
 #' Set Default Options for \pkg{treePlotArea}
 #'
-#' This is just a convenience wrapper to
-#' \code{\link[fritools:set_options]{fritools::set_options}}.
+#' Just convenience function for \code{\link{options}}.
 #' \pkg{treePlotArea} has a set of default options to define the columns of the
 #' \code{\link{data.frame}s} that are passed to
 #' \code{\link{get_correction_factors}}.
 #' See \code{\link{get_defaults}} for a description of these options.
-#' @param ...  See \code{\link[fritools:set_options]{fritools::set_options}}.
+#' @param ... See \code{\link{options}}.
 #' Leave empty to initialize the defaults if need be.
-#' @return See \code{\link[fritools:set_options]{fritools::set_options}}.
+#' @template return_invisibly_true
 #' @family option functions
 #' @export
 #' @examples

R/sedscr

+s/fritools::/fritools_/g