\n",
- css_file))
-
- cat(sprintf("
Vignettes found by %s
",
- deparse1(attr(db, "call"))))
- cat("
")
- for (pkg in names(db)) {
- cat(sprintf("
Vignettes in package %s
\n",
- pkg))
- cat("
\n")
- links <- oneLink(db[[pkg]])
- cat(paste(links), collapse = "\n")
- cat("\n
\n")
- }
- cat("
")
- sink()
- if (port > 0L){
- return(sprintf("http://127.0.0.1:%d/session/%s",
- port, basename(file)))}
- else return(sprintf("file://%s", file))
-}
-
-# for issue 8342 - adding in a count of the number of elements that have missing values by period (and station)
-cumulative_inventory <- function(data, station = NULL, from, to){
- if (is.null(station)){
- data <- data %>%
- dplyr::group_by(.data[[from]], .data[[to]]) %>%
- dplyr::mutate(cum=dplyr::n())
- data <- data %>%
- dplyr::group_by(.data[[from]]) %>%
- dplyr::mutate(cum1 = dplyr::n()) %>%
- dplyr::mutate(cum1 = ifelse(cum == cum1, # are they all in the same period?
- yes = cum,
- no = ifelse(cum == max(cum),
- cum,
- max(cum) + 0.5)))
- } else {
- data <- data %>%
- dplyr::group_by(.data[[station]], .data[[from]], .data[[to]]) %>%
- dplyr::mutate(cum=dplyr::n())
- data <- data %>%
- dplyr::group_by(.data[[station]], .data[[from]]) %>%
- dplyr::mutate(cum1 = dplyr::n()) %>%
- dplyr::mutate(cum1 = ifelse(cum == cum1, # are they all in the same period?
- yes = cum,
- no = ifelse(cum == max(cum),
- cum,
- max(cum) + 0.5)))
- }
- return(data)
-}
-
-getRowHeadersWithText <- function(data, column, searchText, ignore_case, use_regex, match_entire_cell) {
- if (use_regex) {
- # Adjust the search text to match the entire cell if required
- if (match_entire_cell) {
- searchText <- paste0("^", searchText, "$")
- }
- # Find the rows that match the search text using regex
- matchingRows <- stringr::str_detect(data[[column]], stringr::regex(searchText, ignore_case = ignore_case))
- } else if (is.na(searchText)) {
- matchingRows <- apply(data[, column, drop = FALSE], 1, function(row) any(is.na(row)))
- } else {
- # Adjust the search text to match the entire cell if required
- if (match_entire_cell) {
- searchText <- paste0("^", searchText, "$")
- }
- # Find the rows that match the search text
- matchingRows <- grepl(searchText, data[[column]], ignore.case = ignore_case, fixed = TRUE)
- }
- # Get the row headers where the search text is found
- rowHeaders <- rownames(data)[matchingRows]
-
- # Return the row headers
- return(rowHeaders)
-}
-
-# Custom function to convert character to list of numeric vector
-convert_to_list <- function(x) {
- if (grepl("^c\\(", x)) {
- x <- gsub("^c\\(|\\)$", "", x) # Remove 'c(' and ')'
- return(as.numeric(unlist(strsplit(x, ","))))
- } else if (grepl(":", x)) {
- x <- gsub(":", ",", x, fixed = TRUE) # Replace ':' with ','
- return(as.numeric(unlist(strsplit(x, ","))))
- } else {
- return(as.numeric(x))
- }
-}
-
-getExample <- function (topic, package = NULL, lib.loc = NULL, character.only = TRUE, give.lines = FALSE, local = FALSE, echo = TRUE, verbose = getOption("verbose"), setRNG = FALSE, ask = getOption("example.ask"), prompt.prefix = abbreviate(topic, 6), run.dontrun = FALSE, run.donttest = interactive()) {
- if (!character.only) {
- topic <- substitute(topic)
- if (!is.character(topic))
- topic <- deparse(topic)[1L]
- }
- pkgpaths <- find.package(package, lib.loc, verbose = verbose)
- file <- utils:::index.search(topic, pkgpaths, firstOnly = TRUE)
- if (!length(file)) {
- warning(gettextf("no help found for %s", sQuote(topic)),
- domain = NA)
- return(character())
- }
- if (verbose)
- cat("Found file =", sQuote(file), "\n")
- packagePath <- dirname(dirname(file))
- pkgname <- basename(packagePath)
- lib <- dirname(packagePath)
- tf <- tempfile("Rex")
- tools::Rd2ex(utils:::.getHelpFile(file), tf, commentDontrun = !run.dontrun,
- commentDonttest = !run.donttest)
- if (!file.exists(tf)) {
- if (give.lines)
- return(character())
- warning(gettextf("%s has a help file but no examples",
- sQuote(topic)), domain = NA)
- return(character())
- }
- on.exit(unlink(tf))
- example_text <- readLines(tf)
- example_text <- paste(example_text, collapse = "\n")
- if (give.lines) {
- return(example_text)
- }
- if (echo) {
- cat(example_text)
- }
- return(example_text)
-}
-
-WB_evaporation <- function(water_balance, frac, capacity, evaporation_value, rain){
- if (water_balance >= frac*capacity){
- evaporation <- evaporation_value
- } else {
- if (rain == 0){
- evaporation <- evaporation_value * ((water_balance)/(frac*capacity))
- } else {
- if (water_balance < frac*capacity){
- if (rain > evaporation_value){
- evaporation <- evaporation_value
- } else {
- evaporation <- evaporation_value * ((water_balance)/(frac*capacity))
- evaporation <- evaporation + ((evaporation_value - evaporation)*(rain/evaporation_value))
- }
- } else {
- evaporation <- evaporation_value
- }
- }
- }
- return(evaporation)
-}
-
-write_weather_data <- function(year, month, day, rain, mn_tmp, mx_tmp, missing_code, output_file) {
- # Create a data frame with the provided inputs
- weather_data <- data.frame(year = year,
- month = month,
- day = day,
- rain = rain,
- mn_tmp = mn_tmp,
- mx_tmp = mx_tmp)
-
- # Replace missing values with the specified code
- weather_data[is.na(weather_data)] <- missing_code
-
- # Write the data frame to a text file
- write.table(weather_data, file = output_file, sep = "\t", row.names = FALSE, col.names = TRUE, quote = FALSE)
-
- cat("Weather data has been written to", output_file, "\n")
-}
-
-prepare_walter_lieth <- function(data, month, tm_min, ta_min){
- dat_long_int <- NULL
- for (j in seq(nrow(data) - 1)) {
- intres <- NULL
- for (i in seq_len(ncol(data))) {
- if (is.character(data[j, i]) | is.factor(data[j, i])) {
- val <- as.data.frame(data[j, i])
- }
- else {
- interpol <- approx(x = data[c(j, j + 1), "indrow"],
- y = data[c(j, j + 1), i],
- n = 50)
- val <- as.data.frame(interpol$y)
- }
- names(val) <- names(data)[i]
- intres <- dplyr::bind_cols(intres, val)
- }
- dat_long_int <- dplyr::bind_rows(dat_long_int, intres)
- }
- dat_long_int$interpolate <- TRUE
- dat_long_int[[month]] <- ""
- data$interpolate <- FALSE
- dat_long_int <- dat_long_int[!dat_long_int$indrow %in% data$indrow, ]
- dat_long_end <- dplyr::bind_rows(data, dat_long_int)
- dat_long_end <- dat_long_end[order(dat_long_end$indrow), ]
- dat_long_end <- dat_long_end[dat_long_end$indrow >= 0 & dat_long_end$indrow <= 12, ]
- dat_long_end <- tibble::as_tibble(dat_long_end)
-
- getpolymax <- function(x, y, y_lim) {
- initpoly <- FALSE
- yres <- NULL
- xres <- NULL
- for (i in seq_len(length(y))) {
- lastobs <- i == length(x)
- if (y[i] > y_lim[i]) {
- if (isFALSE(initpoly)) {
- xres <- c(xres, x[i])
- yres <- c(yres, y_lim[i])
- initpoly <- TRUE
- }
- xres <- c(xres, x[i])
- yres <- c(yres, y[i])
- if (lastobs) {
- xres <- c(xres, x[i], NA)
- yres <- c(yres, y_lim[i], NA)
- }
- }
- else {
- if (initpoly) {
- xres <- c(xres, x[i - 1], NA)
- yres <- c(yres, y_lim[i - 1], NA)
- initpoly <- FALSE
- }
- }
- }
- poly <- tibble::tibble(x = xres, y = yres)
- return(poly)
- }
- getlines <- function(x, y, y_lim) {
- yres <- NULL
- xres <- NULL
- ylim_res <- NULL
- for (i in seq_len(length(y))) {
- if (y[i] > y_lim[i]) {
- xres <- c(xres, x[i])
- yres <- c(yres, y[i])
- ylim_res <- c(ylim_res, y_lim[i])
- }
- }
- line <- tibble::tibble(x = xres, y = yres, ylim_res = ylim_res)
- return(line)
- }
- prep_max_poly <- getpolymax(x = dat_long_end$indrow, y = pmax(dat_long_end$pm_reesc,
- 50), y_lim = rep(50, length(dat_long_end$indrow)))
- tm_max_line <- getlines(x = dat_long_end$indrow, y = dat_long_end$tm,
- y_lim = dat_long_end$pm_reesc)
- pm_max_line <- getlines(x = dat_long_end$indrow, y = pmin(dat_long_end$pm_reesc,
- 50), y_lim = dat_long_end$tm)
- dat_real <- dat_long_end[dat_long_end$interpolate == FALSE,
- c("indrow", ta_min)]
- x <- NULL
- y <- NULL
- for (i in seq_len(nrow(dat_real))) {
- if (dat_real[i, ][[ta_min]] < 0) {
- x <- c(x, NA, rep(dat_real[i, ]$indrow - 0.5, 2),
- rep(dat_real[i, ]$indrow + 0.5, 2), NA)
- y <- c(y, NA, -3, 0, 0, -3, NA)
- }
- else {
- x <- c(x, NA)
- y <- c(y, NA)
- }
- }
- probfreeze <- tibble::tibble(x = x, y = y)
- rm(dat_real)
- dat_real <- dat_long_end[dat_long_end$interpolate == FALSE,
- c("indrow", tm_min)]
- x <- NULL
- y <- NULL
- for (i in seq_len(nrow(dat_real))) {
- if (dat_real[i, ][[tm_min]] < 0) {
- x <- c(x, NA, rep(dat_real[i, ]$indrow - 0.5, 2),
- rep(dat_real[i, ]$indrow + 0.5, 2), NA)
- y <- c(y, NA, -3, 0, 0, -3, NA)
- }
- else {
- x <- c(x, NA)
- y <- c(y, NA)
- }
- }
- surefreeze <- tibble::tibble(x = x, y = y)
- return_list <- list(dat_long_end,
- tm_max_line,
- pm_max_line,
- prep_max_poly,
- probfreeze,
- surefreeze)
- names(return_list) <- c("dat_long_end", "tm_max_line", "pm_max_line",
- "prep_max_poly", "prob_freeze", "surefreeze")
- return(return_list)
-}
-ggwalter_lieth <- function (data, month, station = NULL, p_mes, tm_max, tm_min, ta_min, station_name = "",
- alt = NA, per = NA, pcol = "#002F70",
- tcol = "#ff0000", pfcol = "#9BAEE2", sfcol = "#3C6FC4",
- shem = FALSE, p3line = FALSE, ...)
- {
-
- # Preprocess data with vectorised operations
- data <- data %>%
- dplyr::mutate(tm = (.data[[tm_max]] + .data[[tm_min]]) / 2,
- pm_reesc = dplyr::if_else(.data[[p_mes]] < 100, .data[[p_mes]] * 0.5, .data[[p_mes]] * 0.05 + 45),
- p3line = .data[[p_mes]] / 3) %>%
- dplyr::mutate(across(.data[[month]], ~ forcats::fct_expand(.data[[month]], ""))) %>%
- dplyr::arrange(.data[[month]])
- # do this for each station, if we have a station
- if (!is.null(station)){
- data <- data %>% group_by(!!sym(station))
- }
- data <- data %>%
- group_modify(~{
- # Add dummy rows at the beginning and end for each group
- .x <- bind_rows(.x[nrow(.x), , drop = FALSE], .x, .x[1, , drop = FALSE])
- # Clear month value for the dummy rows
- .x[c(1, nrow(.x)), which(names(.x) == data[[month]])] <- ""
- # Add an index column for plotting or further transformations
- .x <- cbind(indrow = seq(-0.5, 12.5, 1), .x)
- .x
- })
-
- if (!is.null(station)){
- data <- data %>% ungroup()
- }
- data <- data.frame(data)
-
- # split by station
- if (is.null(station)){
- data_list <- prepare_walter_lieth(data, month, tm_min, ta_min)
- # data things
- dat_long_end <- data_list$dat_long_end
- tm_max_line <- data_list$tm_max_line
- pm_max_line <- data_list$pm_max_line
- prep_max_poly <- data_list$prep_max_poly
- probfreeze <- data_list$prob_freeze
- surefreeze <- data_list$surefreeze
- } else {
- results <-
- map(.x = unique(data[[station]]),
- .f = ~{filtered_data <- data %>% filter(!!sym(station) == .x)
- prepare_walter_lieth(filtered_data, month, tm_min, ta_min)})
- # Function to bind rows for a specific sub-element across all main elements
- n <- length(results)
- m <- length(results[[1]])
- station_name <- unique(data[[station]])
- binds <- NULL
- combined <- NULL
- for (j in 1:m){
- for (i in 1:n) { # for each station data set
- binds[[i]] <- results[[i]][[j]] %>% mutate(!!sym(station) := station_name[i])
- }
- combined[[j]] <- do.call(rbind, binds) # Combine all the sub-elements row-wise
- }
- # data things
- dat_long_end <- combined[[1]]
- tm_max_line <- combined[[2]]
- pm_max_line <- combined[[3]]
- prep_max_poly <- combined[[4]]
- probfreeze <- combined[[5]]
- surefreeze <- combined[[6]]
- }
-
- # data frame pretty things ------------------------------------------------------
- ticks <- data.frame(x = seq(0, 12), ymin = -3, ymax = 0)
- month_breaks <- dat_long_end[dat_long_end[[month]] != "", ]$indrow
- month_labs <- dat_long_end[dat_long_end[[month]] != "", ][[month]]
-
- ymax <- max(60, 10 * floor(max(dat_long_end$pm_reesc)/10) + 10)
- ymin <- min(-3, min(dat_long_end$tm))
- range_tm <- seq(0, ymax, 10)
- if (ymin < -3) {
- ymin <- floor(ymin/10) * 10
- range_tm <- seq(ymin, ymax, 10)
- }
- templabs <- paste0(range_tm)
- templabs[range_tm > 50] <- ""
- range_prec <- range_tm * 2
- range_prec[range_tm > 50] <- range_tm[range_tm > 50] * 20 - 900
- preclabs <- paste0(range_prec)
- preclabs[range_tm < 0] <- ""
-
- wandlplot <- ggplot2::ggplot() + ggplot2::geom_line(data = dat_long_end,
- aes(x = .data$indrow, y = .data$pm_reesc), color = pcol) +
- ggplot2::geom_line(data = dat_long_end, aes(x = .data$indrow,
- y = .data$tm), color = tcol)
- if (nrow(tm_max_line > 0)) {
- wandlplot <- wandlplot + ggplot2::geom_segment(aes(x = .data$x,
- y = .data$ylim_res, xend = .data$x, yend = .data$y),
- data = tm_max_line, color = tcol, alpha = 0.2)
- }
- if (nrow(pm_max_line > 0)) {
- wandlplot <- wandlplot + ggplot2::geom_segment(aes(x = .data$x,
- y = .data$ylim_res, xend = .data$x, yend = .data$y),
- data = pm_max_line, color = pcol, alpha = 0.2)
- }
- if (p3line) {
- wandlplot <- wandlplot + ggplot2::geom_line(data = dat_long_end,
- aes(x = .data$indrow, y = .data$p3line), color = pcol)
- }
- if (max(dat_long_end$pm_reesc) > 50) {
- wandlplot <- wandlplot + ggplot2::geom_polygon(data = prep_max_poly, aes(x, y),
- fill = pcol)
- }
- if (min(dat_long_end[[ta_min]]) < 0) {
- wandlplot <- wandlplot + ggplot2::geom_polygon(data = probfreeze, aes(x = x, y = y),
- fill = pfcol, colour = "black")
- }
- if (min(dat_long_end[[tm_min]]) < 0) {
- wandlplot <- wandlplot + geom_polygon(data = surefreeze, aes(x = x, y = y),
- fill = sfcol, colour = "black")
- }
- wandlplot <- wandlplot + geom_hline(yintercept = c(0, 50),
- linewidth = 0.5) +
- geom_segment(data = ticks, aes(x = x, xend = x, y = ymin, yend = ymax)) +
- scale_x_continuous(breaks = month_breaks, name = "", labels = month_labs, expand = c(0, 0)) +
- scale_y_continuous("C", limits = c(ymin, ymax), labels = templabs,
- breaks = range_tm, sec.axis = dup_axis(name = "mm", labels = preclabs))
- wandlplot <- wandlplot +
- ggplot2::theme_classic() +
- ggplot2::theme(axis.line.x.bottom = element_blank(),
- axis.title.y.left = element_text(angle = 0,
- vjust = 0.9, size = 10, colour = tcol,
- margin = unit(rep(10, 4), "pt")),
- axis.text.x.bottom = element_text(size = 10),
- axis.text.y.left = element_text(colour = tcol, size = 10),
- axis.title.y.right = element_text(angle = 0, vjust = 0.9,
- size = 10, colour = pcol,
- margin = unit(rep(10, 4), "pt")),
- axis.text.y.right = element_text(colour = pcol, size = 10))
-
- if (!is.null(station)){
- wandlplot <- wandlplot + facet_wrap(station)
- }
-
- return(wandlplot)
-}
-
-# Function to check if a repo exists and is in R. Can give either owner and repo, or give url
-check_github_repo <- function(owner = NULL, repo = NULL, url = NULL) {
- if (!is.null(url)){
- # Extract the part after 'github.com'
- url <- sub(".*github.com/", "", url)
-
- # Extract the correct parts
- owner <- dirname(url)
- repo <- basename(url)
- }
- # Check if the package is already installed
- if (requireNamespace(repo, quietly = TRUE)) {
-
- # Get the installed package's remote SHA (if installed via GitHub)
- local_sha <- packageDescription(repo)$GithubSHA1
-
- if (!is.null(local_sha)) {
- # Get the latest commit SHA from the GitHub repository
- latest_commit <- tryCatch({
- response <- gh::gh("/repos/:owner/:repo/commits", owner = owner, repo = repo, .limit = 1)
- response[[1]]$sha
- }, error = function(e) {
- # Handle error if GitHub API call fails
- return(NULL)
- })
-
- if (!is.null(latest_commit)) {
- if (local_sha == latest_commit) {
- return(0) # Package is installed and up-to-date
- } else {
- return(1) # Package is installed but not the latest version
- }
- } else {
- return(2) # Unable to retrieve the latest commit from GitHub
- }
- } else {
- return(3) # Package is installed but not from GitHub
- }
-
- # If not installed, check if the repository exists on GitHub
- } else {
- tryCatch({
- response <- gh::gh("/repos/:owner/:repo", owner = owner, repo = repo, verb = "GET", silent = TRUE)
- if (response$language == "R") {
- return(4) # Repository exists and is in the R language
- } else {
- return(5) # Repository exists, but isn't in the R language
- }
- }, error = function(e) {
- return(6) # Error occurred, repository doesn't exist
- })
- }
-}
-#Convert Decimal to Fractions
-frac10 <- function(x) {paste0(round(x * 10), "/", 10)} #Give fraction our of 10 for a decimal value
-frac20 <- function(x) {paste0(round(x * 20), "/", 20)} #Give fraction our of 20 for a decimal value
-frac100 <- function(x) {paste0(round(x * 100), "/", 100)} # Give fraction our of 100 for a decimal value
-
-frac_den <- function(x, den) {paste0(round(x * den), "/", den)} # Give fraction for a given denominator
-
-# Monitor memory usage function
-monitor_memory <- function() {
- if (.Platform$OS.type == "windows") {
- mem_used <- memory.size()
- } #else {
- # mem_used <- sum(gc()[, "used"]) / 1024 # Convert KB to MB on non-Windows systems
- # }
- return(mem_used)
-}
-
-time_operation <- function(expr) {
- timing <- system.time(expr)
- print(timing)
-}
-
-set_library_paths <- function(library_path) {
- # Update the library paths
- .libPaths(c(library_path, .libPaths()))
-
- # Check if there are more than 2 library paths
- if (length(.libPaths()) > 2) {
- # Get the current library paths
- current_paths <- .libPaths()
-
- # Select valid indices (1 and 3) only if they exist
- valid_indices <- c(1, 3)[c(1, 3) <= length(current_paths)]
-
- # Set the library paths to the valid ones
- .libPaths(current_paths[valid_indices])
- }
-}
+ "August", "September", "October", "November", "December")
\ No newline at end of file
diff --git a/instat/ucrCalculator.vb b/instat/ucrCalculator.vb
index 9e67c8d0cf7..9006a01e089 100644
--- a/instat/ucrCalculator.vb
+++ b/instat/ucrCalculator.vb
@@ -6104,33 +6104,33 @@ Public Class ucrCalculator
Private Sub cmdFrac10_Click(sender As Object, e As EventArgs) Handles cmdFrac10.Click
If chkShowParameters.Checked Then
- ucrReceiverForCalculation.AddToReceiverAtCursorPosition("frac10(x= )", 2)
+ ucrReceiverForCalculation.AddToReceiverAtCursorPosition("instatExtras::frac10(x= )", 2)
Else
- ucrReceiverForCalculation.AddToReceiverAtCursorPosition("frac10( )", 2)
+ ucrReceiverForCalculation.AddToReceiverAtCursorPosition("instatExtras::frac10( )", 2)
End If
End Sub
Private Sub cmdFrac20_Click(sender As Object, e As EventArgs) Handles cmdFrac20.Click
If chkShowParameters.Checked Then
- ucrReceiverForCalculation.AddToReceiverAtCursorPosition("frac20(x= )", 2)
+ ucrReceiverForCalculation.AddToReceiverAtCursorPosition("instatExtras::frac20(x= )", 2)
Else
- ucrReceiverForCalculation.AddToReceiverAtCursorPosition("frac20( )", 2)
+ ucrReceiverForCalculation.AddToReceiverAtCursorPosition("instatExtras::frac20( )", 2)
End If
End Sub
Private Sub cmdFrac100_Click(sender As Object, e As EventArgs) Handles cmdFrac100.Click
If chkShowParameters.Checked Then
- ucrReceiverForCalculation.AddToReceiverAtCursorPosition("frac100(x= )", 2)
+ ucrReceiverForCalculation.AddToReceiverAtCursorPosition("instatExtras::frac100(x= )", 2)
Else
- ucrReceiverForCalculation.AddToReceiverAtCursorPosition("frac100( )", 2)
+ ucrReceiverForCalculation.AddToReceiverAtCursorPosition("instatExtras::frac100( )", 2)
End If
End Sub
Private Sub cmdFracDen_Click(sender As Object, e As EventArgs) Handles cmdFracDen.Click
If chkShowParameters.Checked Then
- ucrReceiverForCalculation.AddToReceiverAtCursorPosition("frac_den(x= ,den= )", 8)
+ ucrReceiverForCalculation.AddToReceiverAtCursorPosition("instatExtras::frac_den(x= ,den= )", 8)
Else
- ucrReceiverForCalculation.AddToReceiverAtCursorPosition("frac_den(, )", 3)
+ ucrReceiverForCalculation.AddToReceiverAtCursorPosition("instatExtras::frac_den(, )", 3)
End If
End Sub
End Class
\ No newline at end of file
diff --git a/instat/ucrFactor.vb b/instat/ucrFactor.vb
index 715ce4f6710..de8d2424aa1 100644
--- a/instat/ucrFactor.vb
+++ b/instat/ucrFactor.vb
@@ -414,6 +414,7 @@ Public Class ucrFactor
clsGetFactorDataFunction.AddParameter("data_name", strDataFrameName)
clsGetFactorDataFunction.AddParameter("col_name", strFactorVariableName)
clsGetFactorDataFunction.AddParameter("include_NA_level", If(bIncludeNALevel, "TRUE", "FALSE"))
+ clsConvertToCharFunction.SetPackageName("instatExtras")
clsConvertToCharFunction.SetRCommand("convert_to_character_matrix")
clsConvertToCharFunction.AddParameter("data", clsRFunctionParameter:=clsGetFactorDataFunction)
expDataFrame = frmMain.clsRLink.RunInternalScriptGetValue(clsConvertToCharFunction.ToScript(), bSilent:=True)