manoSIAR: Datos y Funciones Para Trabajar con el SIA

Documented in v_rango

#' Evaluación valores según de rangos de parámetros
#'
#' Crean mensajes de alerta para casos en los que los valores reportados
#' incumplen relgas de validación. `v_rango` evalúa casos en los que se exceden
#' los rangos normales para los parámetros en cuestión (en base a las tablas
#' \code{\link{rango_param}} y \code{\link{rango_param_sitio}}), o a tablas
#' ingresadas por le usuarie); `v_lim` evalúa los LD y LC en relación a los
#' valores y entre sí; `v_rel_param` evalúa el cumplimiento de las reglas de
#' validación concernientes a las relaciones entre parámetros (ej.: PT >=
#' PO4; esta y otras reglas evaluadas son las contenidas en la lista
#' \code{\link{rel_param}}). Las funciones usan internamente
#' \code{\link{v_rango_}}, \code{\link{v_lim_}} y \code{\link{v_rel_param_}},
#' respectivamente.
#'
#' PENDIENTE (TAL VEZ): crear una versión de `v_rel_param` para trabajar con
#' planillas de vSIA (campo, lab, pd...)
#'
#' @details La data.frame `.data` debe incluir ciertas columnas. Las tres
#'   fundamentales para todas las funciones de validación son **valor** (double;
#'   valor reportado para el parámetro), **id_muestra** (integer; identificador
#'   único de cada muestra; ejs.: \code{\link{sia_muestra}},
#'   \code{\link{datos_sia}}) e **id_parametro** (integer: identificador único
#'   para cada parámetro; ver \code{\link{sia_parametro}}). Adicionalmete,
#'   `v_rango` y `v_lim` necesitan ciertas columnas en `.data`:
#'
#'   - `v_rango` **id_sitio** (integer; identificador único para cada sitio; ver
#'   \code{\link{sitio}}) e **id_matriz** (integer; identificador único para
#'   cada matriz; ver \code{\link{sia_matriz}})
#'
#'   - `v_lim` **limite_deteccion** (double; límite de detección reportado) y
#'   **limite_cuantificacion** (double; límite de cuantificación reportado)
#'
#'   Respecto al argumento `col.ref`: normalmente `id_muestra` es usado. Se
#'   asume que cada valor numérico se puede identificar con la columna de
#'   referencia y el parámetro en cuestión (i.e.: `id_muestra` e `id_parametro`;
#'   por ejemplo, \code{\link{datos_sia}}). En vSIA normalmente se usa "nfila"
#'   como referecia.
#'
#'   Sea cual sea el valor de `col.ref`, los datos en `.data` deben cumplir con
#'   que toda combinación de `col.ref` e `id_parametro` sea única.
#' @param .data data.frame que debe incluir ciertas columnas. Ver detalles.
#' @param col.ref character. Nombre de la columna que hace de referencia con los
#'   datos originales. Ver detalles.
#' @param id_matriz integer, opcional. Si `.data`` no incluye una columna con el
#'   id de matriz de los datos, se puede incluir un escalar entero
#'   correspondiente a la matriz deseada (ver \code{\link{sia_matriz}}).
#' @param trangos data.frame, opcional. En caso de que la tabla
#'   \code{\link{rango_param}} no sea adecuada.
#' @param trangos_sitio data.frame, opcional. En caso de que la tabla
#'   \code{\link{rango_param_sitio}} no sea adecuada.
#'
#' @return data.frame con mensajes de error para las combinaciones de `col.ref`
#'   e `id_parametro` para las que no se cumplen reglas de validación
#'   concernientes. Las columnas de esta tabla son:
#'
#'   - id_muestra (o `col.ref`) (integer): identificador único de cada muestra o
#'   dato.
#'
#'   - id_parametro (integer): identificador único para cada parámetro; ver
#'   \code{\link{sia_parametro}}
#'
#'   - mensaje (character): mensaje de generado (busca ser informativo sin ser
#'   excesivamente extendido)
#'
#'   - id_tipo_msj (integer): identificador único para cada tipo de mensaje
#'   (alerta o error); ver \code{\link{tipo_msj}}
#'
#'   - id_subtipo_msj (integer): identificador único para cada subtipo de
#'   mensaje (independientemente de que sea alerta o error); ver
#'   \code{\link{subtipo_msj}}
#'
#' @export
#'
#' @examples
#'
#' # Con datos (largos):
#'
#' d <- datos_sia %>%
#' valores_numericos(filtrar_otros = TRUE, metodo = "basico") %>%
#'   dplyr::mutate(
#'     limite_deteccion = as.numeric(siabox:::limpia_num(limite_deteccion)),
#'     limite_cuantificacion = as.numeric(limpia_num(limite_cuantificacion))
#'   ) %>%
#'   dplyr::left_join(
#'     dplyr::select(sitio, id_sitio, id_matriz, id_estacion = id_interno),
#'     by = c("id_matriz", "id_estacion")
#'   ) %>%
#'   dplyr::select(id_muestra, id_sitio, codigo_pto, fecha_muestra, id_matriz,
#'                 id_parametro, param, valor, limite_deteccion,
#'                 limite_cuantificacion)
#' msj_rango <- v_rango(d)
#' msj_lim   <- v_lim(d)
#' msj_rel_param <- v_rel_param(d)
#'
#' dplyr::bind_rows(msj_rango, msj_lim, msj_rel_param) %>%
#'   dplyr::group_by(id_subtipo_msj) %>%
#'   dplyr::sample_n(1) %>%
#'   dplyr::left_join(subtipo_msj) %>%
#'   dplyr::select(mensaje, subtipo)
#'
#' # En vSIA:
#' listaPD$datos$`NO3 (mg NO3-N/L)`[11] <- "7,83"
#' listaPD$datos$`NO2 (mg NO2-N/L)`[10] <- "0,71"
#' listaPD$datos$`pH (sin unid)`[11] <- "0,66"
#' listaPD$datos$`PT (µg P/L)`
#' listaPD$datos$`PO4 (µg PO4-P/L)`[2:3] <- c("39", "50")
#' listaPD$datos$`OD (mg/L)`[15] <- "119"
#' listaPD$datos$`SatO2 (%)`[15] <- "9,94"
#'
#' datos_largo <-
#'   largo(listaPD$datos, listaPD$ppd) %>%
#'   valores_numericos(metodo = "basico") %>%
#'   dplyr::mutate(
#'     limite_deteccion = as.numeric(siabox:::limpia_num(limite_deteccion)),
#'     limite_cuantificacion = as.numeric(limpia_num(limite_cuantificacion))
#'   ) %>%
#'   # dplyr::filter(id_tipo_dato == 1L) %>%
#'   dplyr::left_join(sia_parametro[c(1, 4)], by = "id_parametro") %>%
#'   dplyr::left_join(
#'     dplyr::filter(sia_estacion, prog_monitoreo == 13L) %>%
#'       dplyr::select(Estacion = codigo_pto, id_estacion = id),
#'     by = "Estacion"
#'   ) %>%
#'   dplyr::left_join(
#'     dplyr::filter(sitio, id_matriz == 6L, id_fuente == 1L) %>%
#'       dplyr::select(id_sitio, id_matriz, id_estacion = id_interno),
#'     by = "id_estacion"
#'   ) %>%
#'   dplyr::select(nfila, id_sitio, Estacion,
#'                 Fecha, id_matriz, id_parametro,
#'                 nombre_clave, valor,
#'                 limite_deteccion, limite_cuantificacion)
#'
#' v_rango(datos_largo, "nfila")
#' v_lim(datos_largo, "nfila")
#' v_rel_param(datos_largo, "nfila")
#'
#' @name validacion
#' @aliases v_rango, v_lim, v_rel_param
v_rango <- function(.data,
                    col.ref = "id_muestra",
                    id_matriz = NULL,
                    trangos = NULL,
                    trangos_sitio = NULL) {

  col_enc <- names(.data)

  col_esp <- c("id_sitio", "id_parametro", "id_matriz", "valor")

  if (!is.null(id_matriz)) {
    if (any(names(.data) == "id_matriz")) {
      warning(".data contiene columna llamada 'id_matriz': se ignora el ",
              "argumento id_matriz ingresado por le usuarie")
    } else {
      if (!is.numeric(id_matriz))
        stop("id_matriz no es num\u00e9rico (", typeof(id_matriz), ")")
      .data$id_matriz <- as.integer(id_matriz)
    }
  }

  w <- which(!(col_esp %in% col_enc))
  if (length(w)) stop("No se encontraron una o m\u00e1s columnas necesarias ",
                      "en .data: ", colapsar_secuencia(col_esp[w]))

  if (!is.numeric(.data$valor))
    stop(".data$valor no es num\u00e9rico (", typeof(.data$valor), ")")

  if (!is.null(trangos)) {
    if (!is.data.frame(trangos))
      stop("trangos no es data.frame")
    usr <- names(trangos)
    esp <- names(siabox::rango_param)
    w <- which(usr != esp)
    if (length(w)) {
      stop("Los nombres de las columnas de trangos no son los esperados:",
           paste0("\n\tcolumna ", w,
                  ": esperado = '", esp[w],
                  "'; encontrado = '", usr[w], "'"))
    }

    usr <- sapply(trangos, class)
    esp <- sapply(siabox::rango_param, class)
    w <- which(usr != esp)
    if (length(w)) {
      stop("Las clases de las columnas de trangos no son las esperadas:",
           paste0("\n\tcolumna ", w,
                  ": esperado = '", esp[w],
                  "'; encontrado = '", usr[w], "'"))
    }
  } else {
    trangos <- siabox::rango_param
  }

  if (!is.null(trangos_sitio)) {
    if (!is.data.frame(trangos_sitio))
      stop("trangos no es data.frame")
    usr <- names(trangos_sitio)
    esp <- names(siabox::rango_param_sitio)
    w <- which(usr != esp)
    if (length(w)) {
      stop("Los nombres de las columnas de trangos_sitio no son los esperados:",
           paste0("\n\tcolumna ", w,
                  ": esperado = '", esp[w],
                  "'; encontrado = '", usr[w], "'"))
    }

    usr <- sapply(trangos_sitio, class)
    esp <- sapply(siabox::rango_param, class)
    w <- which(usr != esp)
    if (length(w)) {
      stop("Las clases de las columnas de trangos_sitio no son las esperadas:",
           paste0("\n\tcolumna ", w,
                  ": esperado = '", esp[w],
                  "'; encontrado = '", usr[w], "'"))
    }
  } else {
    trangos_sitio <- siabox::rango_param_sitio
  }

  # BLOQUE DE CÓDIGO REPETIDO EN : = = = = = = = = = = = = = = =
  # V_REL_PARAM.DEFAULT
  # V_RANGO
  # V_LIM
  tcpv <- test_col_para_validar(.data, col.ref)
  if (tcpv$tipo) {
    if (tcpv$tipo == 1L) {
      warning(tcpv$mensaje)
      col.ref <- tcpv$col.ref
    } else {
      stop(tcpv$mensaje)
    }
  }
  if (!is.null(tcpv$nombres)) names(.data) <- tcpv$nombres
  # .= = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

  djoins <- .data %>%
    dplyr::left_join(trangos,
                     by = c("id_parametro", "id_matriz")) %>%
    dplyr::left_join(trangos_sitio,
                     by = c("id_sitio", "id_parametro")) %>%
    dplyr::select(id_muestra, id_parametro, tidyselect::starts_with("valor"))

  ev <- with(djoins, v_rango_(valor, valor_min, valor_max,
                              valor_min_sitio, valor_max_sitio))

  out <- NULL

  # Mayor Rango Normal
  if (length(ev[[1]])) {
    out <- djoins[ev[[1]],] %>%
      dplyr::select(id_muestra, id_parametro, valor, valor_max) %>%
      dplyr::mutate(mensaje = paste0(
        "El valor reportado (", valor,
        ") es mayor al valor m\u00e1ximo del rango normal ",
        "para el par\u00e1metro (",
        valor_max, ")"
      ),
      id_tipo_msj = 1L,
      id_subtipo_msj = 8L
      ) %>%
      dplyr::select(-valor:-valor_max) %>%
      dplyr::bind_rows(out, .)
  }

  # Mayor Rango Normal Sitio
  if (length(ev[[2]])) {
    out <- djoins[ev[[2]],] %>%
      dplyr::select(id_muestra, id_parametro, valor, valor_max_sitio) %>%
      dplyr::mutate(mensaje = paste0(
        "El valor reportado (", valor,
        ") es mayor al valor m\u00e1ximo del rango normal ",
        "para el par\u00e1metro y el sitio (",
        valor_max_sitio, ")"
      ),
      id_tipo_msj = 1L,
      id_subtipo_msj = 9L
      ) %>%
      dplyr::select(-valor:-valor_max_sitio) %>%
      dplyr::bind_rows(out, .)
  }

  # Menor Rango Normal
  if (length(ev[[3]])) {
    out <- djoins[ev[[3]],] %>%
      dplyr::select(id_muestra, id_parametro, valor, valor_min) %>%
      dplyr::mutate(mensaje = paste0(
        "El valor reportado (", valor,
        ") es menor al valor m\u00ednimo del rango normal ",
        "para el par\u00e1metro (",
        valor_min, ")"
      ),
      id_tipo_msj = 1L,
      id_subtipo_msj = 10L
      ) %>%
      dplyr::select(-valor:-valor_min) %>%
      dplyr::bind_rows(out, .)
  }

  # Menor Rango Normal Sitio
  if (length(ev[[4]])) {
    out <- djoins[ev[[4]],] %>%
      dplyr::select(id_muestra, id_parametro, valor, valor_min_sitio) %>%
      dplyr::mutate(mensaje = paste0(
        "El valor reportado (", valor,
        ") es menor al valor m\u00ednimo del rango normal ",
        "para el par\u00e1metro y el sitio (",
        valor_min_sitio, ")"
      ),
      id_tipo_msj = 1L,
      id_subtipo_msj = 11L
      ) %>%
      dplyr::select(-valor:-valor_min_sitio) %>%
      dplyr::bind_rows(out, .)
  }

  # BLOQUE DE CÓDIGO REPETIDO EN : = = = = = = = = = = = = = = =
  # V_REL_PARAM.DEFAULT
  # V_RANGO
  # V_LIM
  if (col.ref != "id_muestra" && !is.null(out)) {
    names(out)[1L] <- col.ref
  }
  return(out)
}

#' Prueba: rangos normales de parámetros
#'
#' @param valor numeric Valores a evaluar
#' @param valor_min numeric Valores mínimos esperados por defecto, para los
#'   parámetros correspondientes
#' @param valor_max numeric Valores máximos esperados por defecto, para los
#'   parámetros correspondientes
#' @param valor_min_sitio numeric Valores mínimos esperados por sitio, para los
#'   parámetros correspondientes
#' @param valor_max_sitio numeric Valores máximos esperados por sitio, para los
#'   parámetros correspondientes
#'
#' @return Lista con 4 elementos: 'menor_minimo', 'mayor_maximo',
#'   'menor_minimo_sitio' y 'menor_maximo_sitio', que se corresponden con las
#'   reglas de validación a las que aluden sus nombres (ver `id_subtipo_msj` =
#'   10, 8, 11 y 9 en \code{\link{subtipo_msj}}). Mínimo y máximo, en este
#'   contexto refieren a los rangos normales para cada parámetro, siendo
#'   típicamente los valores encontrados en las tablas \code{\link{rango_param}}
#'   y \code{\link{rango_param_sitio}}
#'
#'   Cada elemento puede ser integer, con las posiciones en las que `valor` esté
#'   por debajo o por encima de los valores numéricos de `valor_min`,
#'   `valor_max`, `valor_min_sitio` o `valor_max_sitio`, según el caso, o
#'   `NULL`, en caso de que ningún elemento de `valor` cumpla estas condiciones.
#' @export
#'
#' @examples
#' v <- c(3640, 35400, 0, 1.572)
#' vmi <- c(1, 1, 1, 1)
#' vma <- c(500, 500, 500, 500)
#' vmis <- c(50, 50, NA, 10000)
#' vmas <- c(15000, 35000, NA, 55000)
#'
#' data.frame(valor = v, valor_min = vmi, valor_max = vma,
#'            valor_min_sitio = vmis, valor_max_sitio = vmas)
#'
#' v_rango_(v, vmi, vma, vmis, vmas)
v_rango_ <- function(valor, valor_min, valor_max,
                     valor_min_sitio, valor_max_sitio) {

  largos <- c(length(valor_min),
              length(valor_max),
              length(valor_min_sitio),
              length(valor_max_sitio))

  if (!all(length(valor) == largos))
    stop("No coinciden los length de todos los argumentos")

  if (!is.numeric(valor))
    stop("valor no es num\u00e9rico (",  typeof(valor),  ")")

  if (!is.numeric(valor_min))
    stop("ld no es num\u00e9rico (", typeof(valor_min), ")")

  if (!is.numeric(valor_max))
    stop("valor_max no es num\u00e9rico (", typeof(valor_max), ")")

  if (!is.numeric(valor_min_sitio))
    stop("valor_min_sitio no es num\u00e9rico (", typeof(valor_min_sitio), ")")

  if (!is.numeric(valor_max_sitio))
    stop("valor_max_sitio no es num\u00e9rico (", typeof(valor_max_sitio), ")")


  out <- list(mayor_maximo = which(valor > valor_max),
              mayor_maximo_sitio = which(valor > valor_max_sitio),
              menor_minimo = which(valor < valor_min),
              menor_minimo_sitio = which(valor < valor_min_sitio))
  return(out)
}

#' @rdname validacion
#' @export
v_lim <- function(.data, col.ref = "id_muestra") {

  # ESTA ASÍ COMO ESTÁ PODRÍA SER V_LIM_ Y LUEGO V_LIM PRODUCE MENSAJES

  col_enc <- names(.data)

  col_esp <- c("valor", "limite_deteccion", "limite_cuantificacion")

  w <- which(!(col_esp %in% col_enc))
  if (length(w)) stop("No se encontraron una o m\u00e1s columnas en .data: ",
                      colapsar_secuencia(col_esp[w]))

  # BLOQUE DE CÓDIGO REPETIDO EN : = = = = = = = = = = = = = = =
  # V_REL_PARAM.DEFAULT
  # V_RANGO
  # V_LIM
  tcpv <- test_col_para_validar(.data, col.ref)
  if (tcpv$tipo) {
    if (tcpv$tipo == 1L) {
      warning(tcpv$mensaje)
      col.ref <- tcpv$col.ref
    } else {
      stop(tcpv$mensaje)
    }
  }
  if (!is.null(tcpv$nombres)) names(.data) <- tcpv$nombres
  # .= = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

  ev <- with(.data, v_lim_(valor, limite_deteccion, limite_cuantificacion))

  # ev <- list(valor_menor_ld = c(8L, 5L, 34L),
  #            valor_menor_lc = 27L,
  #            ld_mayor_lc = c(5L, 22L))
  out <- NULL
  if (length(ev[[1]])) {
    out <-
      .data[ev[[1]], c("id_muestra", "id_parametro", col_esp)] %>%
      dplyr::mutate(mensaje = paste0(
        "El valor reportado (", valor,
        ") es menor al LD (", limite_deteccion, ")"
        ),
        id_tipo_msj = 2L,
        id_subtipo_msj = 33L
        ) %>%
      dplyr::select(- tidyselect::all_of(col_esp)) %>%
      dplyr::bind_rows(out, .)

  }

  if (length(ev[[2]])) {
    out <-
      .data[ev[[2]], c("id_muestra", "id_parametro", col_esp)] %>%
      dplyr::mutate(mensaje = paste0(
        "El valor reportado (", valor,
        ") es menor al LC (", limite_cuantificacion, ")"
      ),
      id_tipo_msj = 2L,
      id_subtipo_msj = 34L
      ) %>%
      dplyr::select(- tidyselect::all_of(col_esp)) %>%
      dplyr::bind_rows(out, .)

  }

  if (length(ev[[3]])) {
    out <-
      .data[ev[[3]], c("id_muestra", "id_parametro", col_esp)] %>%
      dplyr::mutate(mensaje = paste0(
        "El LD reportado (", limite_deteccion,
        ") es mayor o igual al LC (", limite_cuantificacion, ")"
      ),
      id_tipo_msj = 2L,
      id_subtipo_msj = 31L
      ) %>%
      dplyr::select(- tidyselect::all_of(col_esp)) %>%
      dplyr::bind_rows(out, .)

  }
  # subtipo_msj[1:3] %>% print.data.frame()

  # BLOQUE DE CÓDIGO REPETIDO EN : = = = = = = = = = = = = = = =
  # V_REL_PARAM.DEFAULT
  # V_RANGO
  # V_LIM
  if (col.ref != "id_muestra" && !is.null(out)) {
    names(out)[1L] <- col.ref
  }

  return(out)
}

#' Prueba: LD y LC en relación a los valores y entre sí
#'
#' @param valor numeric. Valores a evaluar.
#' @param limite_deteccion numeric. Límites de detección correspondientes
#' @param limite_cuantificacion numeric. Límites de cuantificación
#'   correspondientes
#'
#' @return Lista con 3 elementos: 'valor_menor_ld', 'valor_menor_lc' y
#'   'ld_mayor_lc' y 'menor_maximo_sitio', que se corresponden con las reglas de
#'   validación a las que aluden sus nombres (ver `id_subtipo_msj` = 33, 34 y
#'   31, respectivamente, en \code{\link{subtipo_msj}}).
#'
#'   Cada elemento puede ser integer, con las posiciones en las que `valor`,
#'   `limite_deteccion` y/o `limite_cuantificacion` no cumplen con la regla
#'   correspondiente, o `NULL`, en caso de que ningún elemento de estos vectores
#'   incumple las reglas.
#' @export
#'
#' @examples
#' v <- c(31, 0.006, 0.015)
#' ld <- c(1, 1, 0.01)
#' lc <- c(1, 4, 0.02)
#' v_lim_(v, ld, lc)
v_lim_ <- function(valor, limite_deteccion, limite_cuantificacion) {
  # 2021-10-08: cambié v, ld y lc por los nombres completos (valor,
  # limite_deteccion, limite_cuantificacion), para que si le usuarie se
  # encuentra con estos mensajes de error, pueda entenderlos mejor.

  largos <- c(length(limite_deteccion),
              length(limite_cuantificacion))

  if (!all(length(valor) == largos))
    stop("No coinciden los length de todos los argumentos")

  if (!is.numeric(valor))
    stop("valor no es num\u00e9rico (",  typeof(valor),  ")")

  if (!is.numeric(limite_deteccion))
    stop("limite_deteccion no es num\u00e9rico (",
         typeof(limite_deteccion), ")")

  if (!is.numeric(limite_cuantificacion))
    stop("limite_cuantificacion no es num\u00e9rico (",
         typeof(limite_cuantificacion), ")")

  out <- list(valor_menor_ld = which(valor < limite_deteccion),
              valor_menor_lc = which(valor < limite_cuantificacion),
              ld_mayor_lc = which(limite_deteccion >= limite_cuantificacion))
  return(out)
}

#' @rdname validacion
#' @export
v_rel_param <- function(.data, ...) {
  UseMethod("v_rel_param")
}

#' @rdname validacion
#' @export
v_rel_param.default <- function(.data, col.ref = "id_muestra") {

  # .data <- siabox::datos_sia
  out <- NULL

  # BLOQUE DE CÓDIGO REPETIDO EN : = = = = = = = = = = = = = = =
  # V_REL_PARAM.DEFAULT
  # V_RANGO
  # V_LIM
  tcpv <- test_col_para_validar(.data, col.ref)
  if (tcpv$tipo) {
    if (tcpv$tipo == 1L) {
      warning(tcpv$mensaje)
      col.ref <- tcpv$col.ref
    } else {
      stop(tcpv$mensaje)
    }
  }
  if (!is.null(tcpv$nombres)) names(.data) <- tcpv$nombres
  # .= = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

  da <- tidyr::pivot_wider(.data,
                           id_cols = id_muestra,
                           names_from = id_parametro,
                           values_from = valor)
                           # values_from = c(valor, id_tipo_dato))

  # CAMBIAR v_rel_param_ PARA QUE SEA INTELIGENTE CON EL MANEJO DE LOS CASOS EN
  # LOS QUE EL VALOR ES <LD O <LC, ETC?
  #
  # EN DEIFINITIVA, TODO LO QUE IMPLIQUE QUE ID_TIPO_DATO SEA != 1
  #
  # POR EJEMPLO, SI LA REGLA ES X >= Y, entonces:
  #
  # Si X = "<LC" e Y = 5, uno puede arriesgar que seguramente no está
  # cumpliendo... ahora, si el LC de X es 9? Es tremendo dolor de cabeza la
  # verdad, creo que lo mejor va a ser que funcione bien para todos los casos en
  # los que no hayan "<LC" o "<LD" involucrados. Creo que con valores_numericos,
  # metodo = "basico", antes de crear la data.frame de entrada, deberia
  # funcionar. En el caso de datos_sia, creo que deberia filtrar previamente
  # para quedarme solamente con aquellos que son id_tipo_dato == 1

  rp_out <- v_rel_param_(da[-1])

  if (is.null(rp_out)) return(NULL)

  for (i in 1:length(rp_out)) {
    # Un ejemplo nomás:
    # i <- 1L
    id_p <- rp_out[[i]]$id_parametro

    pnames <- unipar(id_p)$nombre_clave
      # dplyr::transmute(out = paste0(nombre_clave, " (", uni_nombre, ")")) %>%
      # dplyr::pull(out)

    tmp <- da[rp_out[[i]]$filas, c("id_muestra", as.character(id_p))]

    textos <- character(nrow(tmp))

    for (j in 1:length(pnames)) {
      textos <- paste0(textos, "; ", pnames[j], " = ", tmp[[j + 1]])
    }

    # print(rp_out[[i]])

    tmp$textos <- paste0(
      "Regla incumplida: ",
      rp_out[[i]]$regla,
      "; [", gsub("^; ", "", textos), "] ",
      rp_out[[i]]$mensaje
    )

    out <- tmp %>%
      tidyr::pivot_longer(cols = 2:(length(id_p) + 1L)) %>%
      dplyr::mutate(id_parametro = as.integer(name), .after = 1L) %>%
      dplyr::select(1:2, mensaje = textos) %>%
      dplyr::arrange(id_muestra, id_parametro) %>%
      dplyr::bind_rows(out, .)
  }

  out$id_tipo_msj <- 1L
  out$id_subtipo_msj <- 17L

  # BLOQUE DE CÓDIGO REPETIDO EN : = = = = = = = = = = = = = = =
  # V_REL_PARAM.DEFAULT
  # V_RANGO
  # V_LIM
  if (col.ref != "id_muestra" && !is.null(out)) {
    names(out)[1L] <- col.ref
  }

  return(out)
}

# @rdname v_rango
# @method v_rel_param planilla
# v_rel_param.planilla <- function(.data, tcols, metodo_vn = "basico") {
#
#   # INCOMPLETA
#
#   # .data <- listaPD$datos
#   # tcols <- listaPD$ppd
#   matrix_data <- as.matrix(.data)
#   n <- nrow(.data)
#
#   w_par <- which(tcols$tipo == "Valor")
#   npar <- length(w_par)
#   if (!npar) stop("No hay columnas de tipo Valor en tcols?")
#
#   ij <- cbind(rep.int(1:n, npar), rep(tcols$ncol[w_par], each = n))
#   vchar <- matrix_data[ij]
#
#   w_ld <- which(tcols$tipo == "LD")
#   nld  <- length(w_ld)
#
#   w_lc <- which(tcols$tipo == "LC")
#   nlc  <- length(w_lc)
#
#   if (nld != nlc) stop("No hay igual cantidad de columnas LD que LC")
#
#   ij <- cbind(rep.int(1:n, nld), rep(tcols$ncol[w_ld], each = n))
#   ldchar <- matrix_data[ij]
#
#   ij <- cbind(rep.int(1:n, nlc), rep(tcols$ncol[w_lc], each = n))
#   lcchar <- matrix_data[ij]
#
#   if (npar > nld) {
#     ldchar <- c(character(length(vchar) - length(ldchar)), ldchar)
#     lcchar <- c(character(length(vchar) - length(lcchar)), lcchar)
#   }
#
#   dl <- tibble::tibble(
#     nfila = rep.int(1:n, npar),
#     id_parametro = rep(tcols$id_parametro[w_par], each = n),
#     valor_minimo_str = vchar,
#     limite_deteccion = ldchar,
#     limite_cuantificacion = lcchar
#     ) %>%
#     valores_numericos(metodo = metodo_vn)
#
#
#
#
#   w_campo <- which(tcols$tabla == "Campo")
#   vchar <- character(n* npar)
#   ld <- vchar
#   lc <- vchar
#   i <- 0L
#   if (length(w_campo)) {
#     for (i in 1:length(w_campo)) {
#       vchar[((i - 1) * n + 1):(n * i)] <- .data[[tcols$ncol[w_par[i]]]]
#     }
#   }
#   ini <- i + 1L
#
#   for (i in ini:npar) {
#     ind <- ((i - 1) * n + 1):(n * i)
#     vchar[ind] <- .data[[tcols$ncol[w_par[i]]]]
#     # ld[ind] <- .data[[tcols]]
#     # lc[ind]
#   }
#
#   datos_largo <- largo(.data, tcols)
#   datos_largo <- valores_numericos(datos_largo, metodo = "informe")
#   datos_largo <- datos_largo %>%
#     dplyr::mutate(
#       limite_deteccion = as.numeric(limpia_num(limite_deteccion)),
#       limite_cuantificacion = as.numeric(limpia_num(limite_cuantificacion))
#     )
#
# }

#' Prueba: relaciones entre parámetros
#'
#' Función usada internamente por \code{\link{v_rel_param}} para evaluar las
#' reglas contenidas en la lista \code{\link{rel_param}}.
#'
#' @param .data Tabla con datos de parámetros, en la que los valores numéricos
#'   de los parámetros figuran en columnas separadas, nombradas tal como el
#'   id_parametro correspondiente (ver \code{\link{par_id}} o
#'   \code{\link{sia_parametro}})
#'
#' @seealso \code{\link{v_rel_param}}, \code{\link{rel_param}},
#'   \code{\link{ancho}}
#'
#' @return Lista con cuyos elementos se corresponden como las reglas para las
#'   cuales se encontró al menos un caso de incumplimiento. Cada elemento de la
#'   lista contiene los siguientes ítems:
#'
#'   - `id`: número de la regla incumplida
#'
#'   - `regla`: descripción de la regla
#'
#'   - `mensaje`: mensaje emitido cuando la regla **no** se cumple
#'
#'   - `id_parametro`: vector con los id_parametro correspondientes a los
#'   parámetros involucrados en la regla
#'
#'   - `filas`: números de fila en .data, en los que se encontró incumplimientos
#'   de la regla.
#'
#' Los primeros 4 ítems son copiados directamente de  \code{\link{rel_param}}.
#'
#' @export
#'
#' @examples
#' d <- tibble::tibble(`2017` = c(9.75, 98.5, 2.3),
#'                     `2021` = c(32.3, 8.87, 54.1),
#'                     `2097` = c(93, 26, 96),
#'                     `2098` = c(93, 34, 58))
#' v_rel_param_(d)
v_rel_param_ <- function(.data) {
  # nombres <- names(.data)

  # cols_param <- grep("^[0-9]+$", nombres)

  id_cols <- as.integer(names(.data))

  w_na <- which(is.na(id_cols) | is.nan(id_cols))

  if (length(w_na)) {
    stop("Hay columnas con formato incorrecto: ",
         colapsar_secuencia(names(.data)[w_na], comillas = "'"),
         ". \nTodos los nombres de las columnas deben poder convertirse en ",
         "integer. Ejemplos:",
         "\n\t2009\t= OK\n\tfecha\t= MAL!\n\t2020.x\t= MAL!")
  }

  out <- NULL
  j <- 1L

  for (i in 1:length(rel_param)) {
    id_r <- rel_param[[i]]$id_parametro
    w <- unlist(sapply(id_r, function(x) which(id_cols == x)))
    if (length(w) == length(id_r)) {
      w_r <- which(!rel_param[[i]]$fun(.data[w]))
      if (length(w_r)) {
        # message("i: ", i, " - j: ", j)
        out[[j]] <- list(
          id = i,
          regla = rel_param[[i]][[1L]],
          mensaje = rel_param[[i]][[2L]],
          id_parametro = rel_param[[i]][[3L]],
          filas = w_r
        )
        j <- j + 1L
      }
    } else next
  }
  return(out)
}

# . . . . . . . . . . . . . . . . . . . . .  ----

# AUXILIARES ----

#' Test de columnas para varias funciones
#'
#' Utilizado para casos en los que se espera que el usuario ingrese un
#' data.frame para los que alcanza con dos columnas (`col.ref` e `id_parametro`)
#' para identificar inequívocamente cada dato.
#'
#' Se usa en las funciones \code{\link{v_rango}}), \code{\link{v_lim}}) y
#' \code{\link{v_rel_param}}).
#'
#' @param .data data.frame
#' @param col.ref character (1 elemento)
#'
#' @return Lista con formato variable. Elementos:
#'
#'   - tipo: 0, 1 o 2. 0: no hay problemas. 1: hay mensajes de advertencia
#'   (warnings). 2: hay errores.
#'
#'   - mensaje: texto con el mensaje a ser impreso en la consola para el usuario
#'   (independientemente si será mensaje de error o de advertencia)
#'
#'   - nombres: en caso de que sea necesario cambiar el nombre de alguna columna
#'   en `.data`, se incluye este elemento con todos los nombres de columna
#'   resultantes.
#'
#' @examples
#' library(siabox)
#' test_col_para_validar(largo(listaPD$datos, listaPD$ppd), col.ref = "nfila")
test_col_para_validar <- function(.data, col.ref) {

  nombres <- names(.data)
  out <- list(tipo = 0L)
  if (length(col.ref) > 1) {
    out$tipo <- 1L
    out$mensaje <- paste("El argumento 'col.ref' tiene m\u00e1s de un valor,",
                         "por lo que se usar\u00e1 solamente su primer",
                         "elemento")
    out$col.ref <- unlist(col.ref)[1]
  }

  w_id <- which(nombres == "id_muestra")
  if (!length(w_id)) {
    w_ref <- which(nombres == col.ref)
    if (!length(w_ref)) {
      out$tipo <- 2L
      if (col.ref == "id_muestra") {
        out$mensaje <- "No hay columna llamada 'id_muestra' en .data"
      } else {
        out$mensaje <- paste0("No hay columna llamada '", col.ref, "' en .data")
      }
    } else {
      names(.data)[w_ref] <- "id_muestra"
      out$nombres  <- names(.data)
    }
  }

  w_idpar <- which(nombres == "id_parametro")
  if (!length(w_idpar)) {
    out$tipo <- 2L
    out$mensaje <- ".data no tiene columna 'id_parametro'"
  }

  cont <- dplyr::count(.data, id_muestra, id_parametro)
  w_c <- which(cont$n > 1L)
  if (length(w_c)) {
    if (col.ref != "id_muestra") {
      names(cont)[1] <- col.ref
    }
    out$tipo <- 2L
    out$mensaje <- paste0(
      "Se encontraron par\u00e1metros repetidos para algunas muestras:\n",
      paste0(
        "\t", col.ref, " = ", cont[[1]][w_c],
        " e id_parametro = ", cont[[2]][w_c],
        ", repeticiones: ", cont[[3]][w_c],
        collapse = "\n"
      ),
      "\nNo se puede validar si hay muestras con par\u00e1metros repetidos"
    )
  }

  return(out)
}