check_integer <- function(n) {
!grepl("[^[:digit:]]", format(n, digits = 20, scientific = TRUE))
}
convert_to_best_type <- function(vect) {
to_convert <- FALSE
for (i in vect) {
if (check_integer(i)) {
to_convert <- TRUE
break
}
}
if (to_convert) {
suppressWarnings(as.numeric(vect))
} else {
vect
}
}
get_entries_from_hash <- function (model, preselection) {
result <- tibble::tibble()
# Check on stat_unit table
temp <- dplyr::inner_join(model$stat_units, preselection, by = "hash")
if ((n <- nrow(temp)) != 0) {
stat_unit <- temp$stat_unit
date_obs <- rep(NA, n)
hash_stat_unit <- temp$hash
hash_obs <- rep(NA, n)
date_obs_end <- rep(NA, n)
result <- rbind(result, tibble::tibble(hash_stat_unit, stat_unit,
hash_obs, date_obs, date_obs_end))
}
# Check on measures table
temp <- dplyr::inner_join(model$measures, preselection, by = "hash")
if ((n <- nrow(temp)) != 0) {
stat_unit <- temp$stat_unit
date_obs <- temp$date
hash_stat_unit <- hash_from_stat_unit(model, temp$stat_unit)
hash_obs <- temp$hash
date_obs_end <- rep(NA, n)
result <- rbind(result, tibble::tibble(hash_stat_unit, stat_unit,
hash_obs, date_obs, date_obs_end))
}
# Check on events table
temp <- dplyr::inner_join(model$events, preselection, by = "hash")
if ((n <- nrow(temp)) != 0) {
stat_unit <- temp$stat_unit
date_obs <- temp$date
hash_stat_unit <- hash_from_stat_unit(model, temp$stat_unit)
hash_obs <- temp$hash
date_obs_end <- rep(NA, n)
result <- rbind(result, tibble::tibble(hash_stat_unit, stat_unit,
hash_obs, date_obs, date_obs_end))
}
# Check on periods table
temp <- dplyr::inner_join(model$periods, preselection, by = "hash")
if (nrow(temp) != 0) {
stat_unit <- temp$stat_unit
date_obs <- temp$begin
hash_stat_unit <- hash_from_stat_unit(model, temp$stat_unit)
date_obs_end <- temp$end
hash_obs <- temp$hash
result <- rbind(result, tibble::tibble(hash_stat_unit, stat_unit,
hash_obs, date_obs, date_obs_end))
}
result
}
prepare_query <- function(model, condition) {
selection <- tibble::tibble()
if (length(condition) > 2) {
# Method with operator
# Here we admit that a condition is like: tag operator value
# e.g. Temperature > 38.5
#if there's an operator, the information will be in the measure table
operator <- condition[[1]]
if (is.symbol(condition[[3]])) {
# let's select the stat_units that have the query condition
# the list will be in stocked in query$stat_units_selected
tag_to_check <- condition[[3]]
rvalue <- condition [[2]]
# Check on measures table
temp <- subset(model$measures, tag == tag_to_check)
temp <- temp[eval(rlang::call2(operator, rvalue, temp$value)),]
stat_unit <- temp$stat_unit
date_obs <- temp$date
hash_stat_unit <- hash_from_stat_unit(model, temp$stat_unit)
hash_obs <- temp$hash
date_obs_end <- NA
selection <- rbind(selection,
tibble::tibble(hash_stat_unit, stat_unit, hash_obs,
date_obs, date_obs_end))
# Check on descriptions table if there is nothing
if (nrow(selection) == 0) {
temp <- subset(model$descriptions, type == tag_to_check)
temp <- temp[eval(rlang::call2(operator, rvalue,
convert_to_best_type(temp$value))),]
if (nrow(temp) != 0) {
selection <- rbind(selection, get_entries_from_hash(model, temp))
}
}
} else {
# let's select the stat_units that have the query condition
# the list will be in stocked in query$stat_units_selected
tag_to_check <- condition[[2]]
rvalue <- condition [[3]]
# Check on measures table
temp <- subset(model$measures, tag == tag_to_check)
temp <- temp[eval(rlang::call2(operator, temp$value, rvalue)),]
stat_unit <- temp$stat_unit
date_obs <- temp$date
hash_stat_unit <- hash_from_stat_unit(model, stat_unit)
hash_obs <- temp$hash
date_obs_end <- NA
selection <- rbind(selection,
tibble::tibble(hash_stat_unit, stat_unit, hash_obs,
date_obs, date_obs_end))
# Check on descriptions table if there is nothing
if (nrow(selection) == 0) {
temp <- subset(model$descriptions, type == tag_to_check)
temp <- temp[eval(rlang::call2(operator,
convert_to_best_type(temp$value), rvalue)),]
if (nrow(temp) != 0) {
selection <- rbind(selection, get_entries_from_hash(model, temp))
}
}
}
} else {
# Method without operator
# When there is no operator, check events or description,
# measures with description (damn hard)
tag_to_check <- condition
# Check on events table
temp <- subset(model$events, tag == tag_to_check)
stat_unit <- temp$stat_unit
date_obs <- temp$date
hash_stat_unit <- hash_from_stat_unit(model, temp$stat_unit)
hash_obs <- temp$hash
date_obs_end <- NA
selection <- rbind(selection,
tibble::tibble(hash_stat_unit, stat_unit, hash_obs, date_obs, date_obs_end))
# Check on periods table
temp <- subset(model$periods, tag == tag_to_check)
stat_unit <- temp$stat_unit
hash_stat_unit <- hash_from_stat_unit(model, temp$stat_unit)
date_obs <- temp$begin
date_obs_end <- temp$end
hash_obs <- temp$hash
selection <- rbind(selection,
tibble::tibble(hash_stat_unit, stat_unit, hash_obs, date_obs, date_obs_end))
# Check on descriptions table
if (nrow(selection) == 0) {
temp <- subset(model$descriptions, type == tag_to_check)
if (nrow(temp) != 0) {
selection <- rbind(selection, get_entries_from_hash(model, temp))
}
}
}
selection
}
#' observed
#'
#' This function can be complemented by various keywords that do not work alone,
#' see the secondary keywords on the documentation.
#'
#' @param model An AnalysR model
#' @param condition A condition
#'
#' @export
observed <- function(model, condition) {
condition <- rlang::enexpr(condition)
model$selection <- model$selection[0,] # here we reset the selection
model$query <- list() # here we reset the query
model$query$condition <- condition
model$selection <- prepare_query(model, condition)
if (length(condition) > 2) {
if (is.symbol(condition[[3]])) {
model$query$tag <- rlang::as_string(condition[[3]])[1]
} else {
model$query$tag <- rlang::as_string(condition[[2]])[1]
}
} else {
model$query$tag <- rlang::as_string(condition)
}
model
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.