Skip to content

Commit

Permalink
Update examples with internal data
Browse files Browse the repository at this point in the history
  • Loading branch information
@hanecakr
hanecakr committed Nov 7, 2023
1 parent 8c92605 commit b8ec466
Show file tree
Hide file tree
Showing 33 changed files with 2,839 additions and 2,072 deletions.
4 changes: 2 additions & 2 deletions .Rproj.user/429CC01A/pcs/files-pane.pper
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,8 +2,8 @@
"sortOrder": [
{
"columnIndex": 2,
"ascending": true
"ascending": false
}
],
"path": "C:/Users/hanecakr/Documents/R_github/fellingdateR/R"
"path": "C:/Users/hanecakr/Documents/R_github/fellingdateR/tests/testthat"
}
2 changes: 1 addition & 1 deletion .Rproj.user/429CC01A/pcs/windowlayoutstate.pper
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
{
"left": {
"splitterpos": 413,
"splitterpos": 349,
"topwindowstate": "NORMAL",
"panelheight": 830,
"windowheight": 868
Expand Down
236 changes: 134 additions & 102 deletions R/cor_table.R
View file

Large diffs are not rendered by default.

322 changes: 169 additions & 153 deletions R/fd_report.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -66,171 +66,187 @@
#' last = "end",
#' sw_data = "Wazny_1990")
#'
#' dummy2
#' fd_report(dummy2,
#' sw_data = "Sohar_2012_ELL_c")
#'
#' # Example with different sw_model for individual series
#'
#' dummy2
#' sw_models_for_indiv_series <- c("Sohar_2012_ELL_c", "Wazny_1990", "Hollstein_1980", "vanDaalen_Norway", "vanDaalen_Norway")
#' fellingdateR:::dummy2
#' sw_models_for_indiv_series <- c("Sohar_2012_ELL_c",
#' "Wazny_1990",
#' "Hollstein_1980",
#' "vanDaalen_Norway",
#' "vanDaalen_Norway")
#'
#' dummy2_edit <- cbind(dummy2, sw_models_for_indiv_series)
#' dummy2_edit <- cbind(fellingdateR:::dummy2, sw_models_for_indiv_series)
#'
#' fd_report(dummy2_edit,
#' sw_data = sw_models_for_indiv_series
#' sw_data = "sw_models_for_indiv_series"
#' )
#'
#' @export
#' @seealso [sw_interval()], [sw_data_overview()], [sw_interval_plot()]

fd_report <- function(
x,
series = "series",
last = "last",
n_sapwood = "n_sapwood",
waneyedge = "waneyedge",
sw_data = "Hollstein_1980",
credMass = 0.954,
densfun = "lognormal",
sep = ";") {

df <- as.data.frame(x)
# Check columns exist
if (!series %in% names(df)) {
stop("--> 'series' does not exist")
}
if (!last %in% names(df)) {
stop("--> 'last' does not exist")
}
if (!n_sapwood %in% names(df)) {
stop("--> 'n_sapwood' does not exist")
}
if (!waneyedge %in% names(df)) {
stop("--> 'waneyedge' does not exist")
}
series <- df[[series]] # check for NA's
if (any(is.na(series))) {
stop("--> some 'series' have no id")
}
n_sapwood <- df[[n_sapwood]] # check is.numeric
if (is.character(n_sapwood)) { # was !is.numeric !!!
stop("--> 'n_sapwood' must be a numeric vector")
}
last <- df[[last]] # check is.numeric
if (!is.numeric(last)) {
stop("--> 'last' must be a numeric vector")
}
waneyedge <- df[[waneyedge]] # check is.logical
if (!is.logical(waneyedge)) {
warning(
"--> 'waneyedge' should be a logical vector (TRUE/FALSE),
fd_report <- function(x,
series = "series",
last = "last",
n_sapwood = "n_sapwood",
waneyedge = "waneyedge",
sw_data = "Hollstein_1980",
credMass = 0.954,
densfun = "lognormal",
sep = ";") {
df <- as.data.frame(x)
# Check columns exist
if (!series %in% names(df)) {
stop("--> 'series' does not exist")
}
if (!last %in% names(df)) {
stop("--> 'last' does not exist")
}
if (!n_sapwood %in% names(df)) {
stop("--> 'n_sapwood' does not exist")
}
if (!waneyedge %in% names(df)) {
stop("--> 'waneyedge' does not exist")
}
series <- df[[series]] # check for NA's
if (any(is.na(series))) {
stop("--> some 'series' have no id")
}
n_sapwood <- df[[n_sapwood]] # check is.numeric
if (is.character(n_sapwood)) {
# was !is.numeric !!!
stop("--> 'n_sapwood' must be a numeric vector")
}
last <- df[[last]] # check is.numeric
if (!is.numeric(last)) {
stop("--> 'last' must be a numeric vector")
}
waneyedge <- df[[waneyedge]] # check is.logical
if (!is.logical(waneyedge)) {
warning(
"--> 'waneyedge' should be a logical vector (TRUE/FALSE),
indicating the presence of waney edge.\n",
"--> Converted to TRUE/FALSE based on presence of string 'wK'."
)
waneyedge <-
ifelse(grepl("wk", waneyedge, ignore.case = TRUE),
TRUE,
FALSE)
}
if (is.na(credMass) || credMass <= 0 || credMass >= 1)
stop("--> credMass must be between 0 and 1")


# sw_data fixed for all series
if (sw_data %in% sw_data_overview() || file.exists(sw_data)) {
sw_data <- rep(sw_data, nrow(df))
}
# sw_data might differ between series and is provided in a separate column
else if (sw_data %in% colnames(df)) {
sw_data <- df[[sw_data]]
sw_OK <- which(sw_data %in% sw_data_overview() | file.exists(sw_data))
if (length(sw_OK) < length(sw_data)){ stop(sprintf("'%s' is not a supported sapwood model, or file doesn't exist\n", sw_data[-sw_OK]))}
} else {
stop(sprintf(
"--> sw_data should be one of `sw_data_overview()`
)
waneyedge <-
ifelse(grepl("wk", waneyedge, ignore.case = TRUE),
TRUE,
FALSE)
}
if (is.na(credMass) || credMass <= 0 || credMass >= 1)
stop("--> credMass must be between 0 and 1")


# sw_data fixed for all series
if (sw_data %in% sw_data_overview() || file.exists(sw_data)) {
sw_data <- rep(sw_data, nrow(df))
}
# sw_data might differ between series and is provided in a separate column
else if (sw_data %in% colnames(df)) {
sw_data <- df[[sw_data]]
sw_OK <-
which(sw_data %in% sw_data_overview() | file.exists(sw_data))
if (length(sw_OK) < length(sw_data)) {
stop(
sprintf(
"'%s' is not a supported sapwood model, or file doesn't exist\n",
sw_data[-sw_OK]
)
)
}
} else {
stop(
sprintf(
"--> sw_data should be one of `sw_data_overview()`
or the path to a .csv file with columns `n_sapwood` and `count`,\n
not '%s'.", sw_data))}

interval_matrix <- matrix(nrow = nrow(df),
ncol = 8)

for (i in 1:length(series)) {

series_i <- series[i]
n_sapwood_i <- n_sapwood[i]
last_i <- last[i]
waneyedge_i <- waneyedge[i]
sw_data_i <- sw_data[i]

if (waneyedge_i) {
lower_i <- NA
upper_i <- last_i
} else if (!is.na(n_sapwood_i) && !is.na(last_i)){
interval_i <- sw_interval(n_sapwood = n_sapwood_i,
last = last_i,
hdi = TRUE,
credMass = credMass,
sw_data = sw_data_i,
densfun = densfun,
sep = sep
)
lower_i <- interval_i[[1]]
upper_i <- interval_i[[2]]
} else if (is.na(n_sapwood_i) && !is.na(last_i)) {
interval_i <- sw_interval(n_sapwood = 0,
last = last_i,
hdi = TRUE,
credMass = credMass,
sw_data = sw_data_i,
densfun = densfun,
sep = sep)
lower_i <- interval_i[[1]]
upper_i <- NA
} else if (is.na(last_i)) {
lower_i <- NA
upper_i <- NA
}

if (!is.na(lower_i) && !is.na(upper_i)){
verbal_i <- paste0("between ", lower_i, " and ", upper_i)
} else if (!is.na(lower_i) && is.na(upper_i)) {
verbal_i <- paste0("after ", lower_i)
} else if (is.na(lower_i) && !is.na(upper_i)) {
verbal_i <- paste0("in ", upper_i)
} else if (is.na(lower_i) && is.na(upper_i)) {
verbal_i <- "undated"
}

interval_matrix[i, 1] <- series_i
interval_matrix[i, 2] <- last_i
interval_matrix[i, 3] <- n_sapwood_i
interval_matrix[i, 4] <- waneyedge_i
interval_matrix[i, 5] <- lower_i
interval_matrix[i, 6] <- upper_i
interval_matrix[i, 7] <- verbal_i
interval_matrix[i, 8] <- sw_data_i

colnames(interval_matrix) <- c("series",
"last",
"n_sapwood",
"waneyedge",
"lower",
"upper",
"felling_date",
"sapwood_model"
)

}

interval_matrix <- as.data.frame(interval_matrix)
interval_matrix[, c(2, 3, 5, 6)] <-
lapply(c(2, 3, 5, 6), function(x) as.numeric(interval_matrix[, x]))
interval_matrix[, 4] <- as.logical(interval_matrix[, 4])

attr(interval_matrix, "credMass") <- credMass
attr(interval_matrix, "model") <- densfun

return(interval_matrix)
not '%s'.",
sw_data
)
)
}

interval_matrix <- matrix(nrow = nrow(df),
ncol = 8)

for (i in 1:length(series)) {
series_i <- series[i]
n_sapwood_i <- n_sapwood[i]
last_i <- last[i]
waneyedge_i <- waneyedge[i]
sw_data_i <- sw_data[i]

if (waneyedge_i) {
lower_i <- NA
upper_i <- last_i
} else if (!is.na(n_sapwood_i) && !is.na(last_i)) {
interval_i <- sw_interval(
n_sapwood = n_sapwood_i,
last = last_i,
hdi = TRUE,
credMass = credMass,
sw_data = sw_data_i,
densfun = densfun,
sep = sep
)
lower_i <- interval_i[[1]]
upper_i <- interval_i[[2]]
} else if (is.na(n_sapwood_i) && !is.na(last_i)) {
interval_i <- sw_interval(
n_sapwood = 0,
last = last_i,
hdi = TRUE,
credMass = credMass,
sw_data = sw_data_i,
densfun = densfun,
sep = sep
)
lower_i <- interval_i[[1]]
upper_i <- NA
} else if (is.na(last_i)) {
lower_i <- NA
upper_i <- NA
}

if (!is.na(lower_i) && !is.na(upper_i)) {
verbal_i <- paste0("between ", lower_i, " and ", upper_i)
} else if (!is.na(lower_i) && is.na(upper_i)) {
verbal_i <- paste0("after ", lower_i)
} else if (is.na(lower_i) && !is.na(upper_i)) {
verbal_i <- paste0("in ", upper_i)
} else if (is.na(lower_i) && is.na(upper_i)) {
verbal_i <- "undated"
}

interval_matrix[i, 1] <- series_i
interval_matrix[i, 2] <- last_i
interval_matrix[i, 3] <- n_sapwood_i
interval_matrix[i, 4] <- waneyedge_i
interval_matrix[i, 5] <- lower_i
interval_matrix[i, 6] <- upper_i
interval_matrix[i, 7] <- verbal_i
interval_matrix[i, 8] <- sw_data_i

colnames(interval_matrix) <- c(
"series",
"last",
"n_sapwood",
"waneyedge",
"lower",
"upper",
"felling_date",
"sapwood_model"
)

}

interval_matrix <- as.data.frame(interval_matrix)
interval_matrix[, c(2, 3, 5, 6)] <-
lapply(c(2, 3, 5, 6), function(x)
as.numeric(interval_matrix[, x]))
interval_matrix[, 4] <- as.logical(interval_matrix[, 4])

attr(interval_matrix, "credMass") <- credMass
attr(interval_matrix, "model") <- densfun

return(interval_matrix)

}
12 changes: 6 additions & 6 deletions R/get_header.R
View file
Original file line number Diff line number Diff line change
@@ -1,12 +1,12 @@
#' Retrieve the HEADER fields of a Heidelberg format (.fh) file
#'
#' @description This function reports the HEADER fields from a Heidelberg
#' format (.fh) ring-width file. The header fields are harvested from the
#' .fh-file by the `read_fh()` function, which stores the HEADER fields from
#' the .fh file as attributes of the `data.frame` with the measurement data it returns.
#' @description This function reports the HEADER fields from a Heidelberg format
#' (.fh) ring-width file. The header fields are harvested from the .fh-file by
#' the `read_fh()` function, which stores the HEADER fields from the .fh file
#' as attributes of the `data.frame` with the measurement data it returns.
#'
#' @param rwl The output of `read_fh(x, header = TRUE)`,
#' a `data.frame` of class `rwl`.
#' @param rwl The output of `read_fh(x, header = TRUE)`, a `data.frame` of class
#' `rwl`.
#'
#' @return A `data.frame` with 29 header fields.
#'
Expand Down
Loading

0 comments on commit b8ec466

Please sign in to comment.