Merge pull request #27 from felipe-treistman/validacoes

Validacoes

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: smapOnsR
 Title: SMAP/ONS
-Version: 0.2.2
+Version: 0.3.0
 Authors@R: 
     person("Felipe", "Treistman", , "[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-9948-8680"))

NAMESPACE

@@ -63,6 +63,8 @@ export(rodada_varios_dias)
 export(totaliza_previsao)
 export(transforma_NC_serie)
 export(transforma_historico_previsao)
+export(valida_cenarios)
+export(valida_previsao_etp)
 importFrom(DT,dataTableOutput)
 importFrom(DT,renderDataTable)
 importFrom(arrow,read_parquet)
@@ -76,6 +78,7 @@ importFrom(data.table,setcolorder)
 importFrom(data.table,setnames)
 importFrom(data.table,setorder)
 importFrom(doParallel,registerDoParallel)
+importFrom(funcaoSmapCpp,rodada_cenarios_dias_cpp2)
 importFrom(funcaoSmapCpp,rodada_varios_dias_cpp2)
 importFrom(future,future)
 importFrom(future,resolved)

NEWS.md

@@ -1,3 +1,24 @@
+# smapOnsR 0.3.0
+
+## Major changes
+
+* Processo de calibração paralelizado
+
+## Minor changes
+
+* Ajuste na validacao de arquivo de inicializacao oficial, e de previsao nova
+
+* Inclusao de teste de validacao de previsao nova
+
+* Ajuste em arquivos exemplo
+
+* Ajuste na leitura de arquivo de precipitacao observada, "modelos_precipitacao" e "_parametros" oficial
+
+* Alteracao do teste das funcoes de rodadas_encadeadas
+
+* Criacao de arquivo com funcoes de validacao de dados de entrada (futuramente todas as validacoes de arquivos de entrada estará contida nesse arquivo)
+
+
 # smapOnsR 0.2.2
 
 ## Bug fixes

R/assimilacao.R

@@ -218,6 +218,7 @@ assimilacao_oficial <- function(vetor_modelo, area, EbInic, TuInic, Supin, preci
 #' fo
 #' 
 #' @importFrom data.table data.table
+#' @importFrom funcaoSmapCpp rodada_varios_dias_cpp2
 #' @return objetivo valor da funcao objetivo
 #' @export
 

R/leitura_antiga.R

@@ -20,7 +20,9 @@ le_entrada_parametros <- function(pasta_entrada, nome_subbacia) {
         stop(paste0("nao existe o arquivo ", pattern))
     }
 
-    parametros <- read.csv(arq, comment.char = "'", header = FALSE, sep = ";")
+    parametros <- data.table::fread(arq, header = FALSE, blank.lines.skip = TRUE, sep = ";")
+    parametros[, V1 := iconv(V1, "ASCII", "UTF-8", sub = "")]
+    parametros[, V1 := strsplit(V1, split = "'")[[1]][1], by = V1]
 
     parametros_smap <- array(rep(0, 82), c(1, 82))
     parametros_smap <- data.table::data.table(parametros_smap)
@@ -31,8 +33,8 @@ le_entrada_parametros <- function(pasta_entrada, nome_subbacia) {
     aux <- strsplit(arq, split = "/")[[1]]
     parametros_smap$nome <- tolower(sub(".*/", "", sub("_parametros.txt", "", nome_subbacia)))
     parametros_smap$Area <- as.numeric(parametros[1, 1])
-    if (!is.character(parametros[2, 1])) stop(paste0("Nao existe valores de kt declarados no arquivo ", arq))
-    aux <- unlist(strsplit(parametros[2, 1], "\\s+"))
+    if (!is.character(parametros[2, V1])) stop(paste0("Nao existe valores de kt declarados no arquivo ", arq))
+    aux <- unlist(strsplit(parametros[2, V1], "\\s+"))
     parametros_smap$nKt <- as.numeric(aux[1])
     if (is.na(parametros_smap$nKt)) stop(paste0("Parametro de numero de kt com valor nao numerico no arquivo ", arq))    
     if(as.numeric(aux[1]) != length(aux) - 1) stop(paste0("Numero de kt diferente do total de kt declarado no arquivo ", arq))    
@@ -43,7 +45,7 @@ le_entrada_parametros <- function(pasta_entrada, nome_subbacia) {
     }
 
     for (iparametro in 67:80) {
-        parametros_smap[1, iparametro] <- as.numeric(parametros[(iparametro - 64), 1])
+        parametros_smap[1, iparametro] <- as.numeric(parametros[(iparametro - 64), V1])
     }
 
     parametros_smap[1, 81] <- sum(parametros_smap[, 7:66] > 0)
@@ -473,8 +475,11 @@ le_entrada_modelos_precipitacao <- function(pasta_entrada) {
         stop("nao existe o arquivo do tipo modelos_precipitacao.txt")
     }
 
-    dat <- data.table::as.data.table(read.csv(arq, header = FALSE, comment.char = "'", fill = TRUE))
+    dat <- data.table::fread(arq, header = FALSE, blank.lines.skip = TRUE, sep = ";")
+    dat[, V1 := iconv(V1, "ASCII", "UTF-8", sub = "")] 
+    dat[, V1 := strsplit(V1, split = "'")[[1]][1], by = V1]
     dat[, V1 := tolower(V1)]
+    dat[, V1 := trimws(V1)]
     numero_cenarios <- as.numeric(dat[1, V1])
 
     if (is.na(numero_cenarios)) stop("Valor nao numerico de cenarios no arquivo modelos_precipitacao.txt")
@@ -1050,4 +1055,4 @@ le_arq_entrada <- function(pasta_entrada) {
         datas_rodadas = datas_rodadas, caso = caso)
 
     saida
-}
+}

R/leitura_nova.R

@@ -210,7 +210,7 @@ le_precipitacao_prevista <- function(arq) {
     for (idata in 1:dat[, length(unique(data_rodada))]) {
         data <- dat[, unique(data_rodada)[idata]]
         datas_previstas <- dat[data_rodada == data, unique(data_previsao)]
-        teste <- dat[data_rodada == data, setdiff(datas_previstas, data_previsao), by = c( "nome", "cenario")]
+        teste <- dat[data_rodada == data, setdiff(datas_previstas, data_previsao), by = c("nome", "cenario", "data_rodada")]
         teste_completo <- data.table::rbindlist(list(teste_completo, teste))
     }
 
@@ -679,6 +679,7 @@ le_arq_entrada_novo <- function(pasta_entrada) {
             if (!all(sub_bacias$nome %in% evapotranspiracao_prevista$nome)) {
                 stop(paste0("Falta a sub-bacia ", sub_bacias[!nome %in% evapotranspiracao_prevista$nome, nome], " no arquivo ", arquivos[arquivo == "EVAPOTRANSPIRACAO_PREVISTA", nome_arquivo], ".\n"))
             }
+            valida_previsao_etp(evapotranspiracao_prevista, precipitacao_prevista)
         } else {
             warning("nao existe arquivo de previsao de evapotranspiracao, serao utilizados dados historicos")
 

R/rodadas_encadeadas.R

@@ -53,6 +53,7 @@
 #'     }
 #' @param sub_bacias vetor com o nome das sub-bacias a serem consideradas
 #' @importFrom data.table data.table
+#' @importFrom funcaoSmapCpp rodada_cenarios_dias_cpp2
 #' @return saida lista com o data.table previsao contendo as seguintes colunas:
 #'     \itemize{
 #'     \item{data_caso - data da rodada}
@@ -349,6 +350,7 @@ rodada_encadeada_oficial <- function(parametros, inicializacao, precipitacao_obs
 #'     }
 #' @param sub_bacias vetor com o nome das sub-bacias a serem consideradas
 #' @importFrom data.table data.table
+#' @importFrom funcaoSmapCpp rodada_cenarios_dias_cpp2
 #' @return saida lista com o data.table previsao contendo as seguintes colunas:
 #'     \itemize{
 #'     \item{data_caso - data da rodada}

R/validacao_entrada.R

@@ -0,0 +1,67 @@
+# VALIDACAO DE ENTRADA 
+
+#' valida_previsao_etp
+#' 
+#' Validador de arquivo de previsao de etp
+#' 
+#' @param evapotranspiracao_prevista data.table com a evapotranspiracao prevista com as colunas
+#'     \itemize{
+#'     \item{data_rodada - data da rodada do modelo que gerou a previsao}
+#'     \item{data_previsao - data da previsao}
+#'     \item{cenario - codigo do cenario}
+#'     \item{nome - nome da sub bacia}
+#'     \item{valor - valor da previsao de precipitacao}
+#'     }
+#' @param precipitacao_prevista data.table com a precipitacao prevista com as colunas
+#'     \itemize{
+#'     \item{data_rodada - data da rodada do modelo que gerou a previsao}
+#'     \item{data_previsao - data da previsao}
+#'     \item{cenario - codigo do cenario}
+#'     \item{nome - nome da sub bacia}
+#'     \item{valor - valor da previsao de precipitacao}
+#'     }
+#' @export 
+valida_previsao_etp <- function(evapotranspiracao_prevista, precipitacao_prevista) {
+
+    valida_cenarios(evapotranspiracao_prevista, precipitacao_prevista)
+}
+
+#' valida_cenarios
+#' 
+#' Valida se para cada valor unico de nome, data_previsao e data_rodada existem os mesmos
+#' cenarios
+#' 
+#' @param evapotranspiracao_prevista data.table com a evapotranspiracao prevista com as colunas
+#'     \itemize{
+#'     \item{data_rodada - data da rodada do modelo que gerou a previsao}
+#'     \item{data_previsao - data da previsao}
+#'     \item{cenario - codigo do cenario}
+#'     \item{nome - nome da sub bacia}
+#'     \item{valor - valor da previsao de precipitacao}
+#'     }
+#' @param precipitacao_prevista data.table com a precipitacao prevista com as colunas
+#'     \itemize{
+#'     \item{data_rodada - data da rodada do modelo que gerou a previsao}
+#'     \item{data_previsao - data da previsao}
+#'     \item{cenario - codigo do cenario}
+#'     \item{nome - nome da sub bacia}
+#'     \item{valor - valor da previsao de precipitacao}
+#'     }
+#' @export 
+valida_cenarios <- function(evapotranspiracao_prevista, precipitacao_prevista) {
+
+    merged_data <- merge(precipitacao_prevista, evapotranspiracao_prevista,
+                     by = c("data_previsao", "nome", "data_rodada", "cenario"), all = TRUE)
+
+    if (nrow(merged_data[is.na(valor.x)]) != 0) {
+        stop(paste0("falta o cenario ", merged_data$cenario, " para a data de previsao ", 
+        merged_data$data_previsao, " da sub-bacia ", merged_data$nome, 
+        " do caso de ", merged_data$data_rodada, " no arquivo de previsao de precipitacao. \n"))
+    }
+
+    if (nrow(merged_data[is.na(valor.y)]) != 0) {
+        stop(paste0("falta o cenario ", merged_data$cenario, " para a data de previsao ", 
+        merged_data$data_previsao, " da sub-bacia ", merged_data$nome, 
+        " do caso de ", merged_data$data_rodada, " no arquivo de previsao de evapotranspiracao. \n"))
+    }
+}

tests/testthat/test-execucao.R

@@ -26,16 +26,17 @@ test_that("testa execucao oficial", {
 })
 
 test_that("testa execucao novo formato", {
+  library(smapOnsR)
   pasta_entrada <- system.file("extdata", "arq_entrada_novo", package = "smapOnsR")
 
   saida <- suppressWarnings(executa_caso_novo(pasta_entrada))
 
   secao <- sessionInfo()
 
   if (secao$R.version$os == "mingw32") {
-  #  expect_equal(round(saida$previsao[nome == "avermelha" & variavel == "Qcalc" & cenario == "historico", valor][27], 0), 730)
+    expect_equal(round(saida$previsao[nome == "avermelha" & variavel == "Qcalc" & cenario == "historico", valor][1], 2), 345.11)
   } else {
-    expect_true(abs(round(saida$previsao[nome == "avermelha" & variavel == "Qcalc" & cenario == "historico", valor][27], 0) - 730) < 730 * 0.01)
+    expect_true(abs(round(saida$previsao[nome == "avermelha" & variavel == "Qcalc" & cenario == "historico", valor][1], 2) - 345.11) < 345.11 * 0.01)
   }
 
   unlink(system.file("extdata", "Arq_Entrada", package = "smapOnsR"), recursive = TRUE)

tests/testthat/test-leitura_nova.R

@@ -198,8 +198,11 @@ test_that("testa precipitacao_prevista.csv", {
     arq <- system.file("extdata", "validacao_arq_entrada_novo", "CN18", "CT18.11", "Arq_Entrada", "precipitacao_prevista.csv", package = "smapOnsR")
     expect_error(suppressWarnings(le_precipitacao_prevista(arq)))
 
-    arq <- system.file("extdata", "validacao_arq_entrada_novo", "CN18", "CT18.12", "Arq_Entrada", "precipitacao_prevista.csv", package = "smapOnsR")
-    expect_error(suppressWarnings(le_precipitacao_prevista(arq)))
+    arq_prec <- system.file("extdata", "validacao_arq_entrada_novo", "CN18", "CT18.12", "precipitacao_prevista.csv", package = "smapOnsR")
+    arq_etp <- system.file("extdata", "validacao_arq_entrada_novo", "CN18", "CT18.12", "evapotranspiracao_prevista.csv", package = "smapOnsR")
+    precipitacao_prevista <- data.table::fread(arq_prec)
+    evapotranspiracao_prevista <- data.table::fread(arq_etp)
+    expect_error(valida_cenarios(evapotranspiracao_prevista, precipitacao_prevista))
 })
 
 test_that("testa vazoes.csv", {