Release version 23.10.0 (#46)

* Aic bic (#37) * tighten priors * implement AIC/BIC UI * hide edf * fix for old models * extract create table function, add test (#38) * extract create table function, add test * update docu * update tests for fitPlotRModel * fix typo * extract log likelihood computation (#39) * extract log likelihood computation * update docu * create test data from debugging in original function, add test to extracted function * add other case to test * Update DESCRIPTION * fix XX / XX2 * add some comments --------- Co-authored-by: Antonia Runge <antonia.runge@inwt-statistics.de> * Feat/apply model import from datatools (#43) * add yaml config * apply config * use modelimport from dataTools, remove old module * clean up namespace * update news.md, clean up * load yaml inside server.R * add parameter * Update cosign-installer version * "About" of pandora repository * update config, add help * update news.md --------- Co-authored-by: Marcus Groß <marcus.gross@inwt-statistics.de> Co-authored-by: Jan Abel <106665518+jan-abel-inwt@users.noreply.github.com>
Pandora-IsoMemo · Oct 2, 2024 · 3d67086 · 3d67086
1 parent 3105000
commit 3d67086
Show file tree

Hide file tree

Showing 29 changed files with 584 additions and 275 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: PlotR
 Title: Plot things
-Version: 24.04.0
+Version: 24.04.0.1
 Authors@R: c(
     person("Marcus", "Gross", email = "marcus.gross@inwt-statistics.de", role = c("aut", "cre")),
     person("Ricardo", "Fernandes", email = "ldv1452@gmail.com", role = c("aut")),
@@ -27,7 +27,7 @@ Imports:
   shinyjs,
   shinythemes,
   tibble,
-  zip
+  yaml
 License: GPL (>= 3)
 Encoding: UTF-8
 LazyData: true

diff --git a/NAMESPACE b/NAMESPACE
@@ -4,11 +4,15 @@ export(addMoreData)
 export(addMoreDataUI)
 export(addMorePoints)
 export(addMorePointsUI)
+export(config)
 export(downUploads)
 export(downUploadsUI)
 export(exportCSV)
 export(exportFilename)
 export(exportXLSX)
+export(getHelp)
+export(goodnessOfFit)
+export(goodnessOfFitUI)
 export(multiplePlots)
 export(multiplePlotsUI)
 export(multiplePredictions)
@@ -27,10 +31,10 @@ importFrom(DT,DTOutput)
 importFrom(DT,renderDT)
 importFrom(DataTools,checkErrorNoNumericColumns)
 importFrom(DataTools,checkWarningEmptyValues)
+importFrom(DataTools,downloadModelServer)
+importFrom(DataTools,downloadModelUI)
 importFrom(DataTools,importDataServer)
 importFrom(DataTools,importDataUI)
-importFrom(DataTools,remoteModelsServer)
-importFrom(DataTools,remoteModelsUI)
 importFrom(DataTools,tryCatchWithWarningsAndErrors)
 importFrom(Rfast,rmvnorm)
 importFrom(Rfast,spdinv)
@@ -66,7 +70,6 @@ importFrom(magrittr,"%>%")
 importFrom(mgcv,Predict.matrix)
 importFrom(mgcv,s)
 importFrom(mgcv,smoothCon)
-importFrom(openxlsx,read.xlsx)
 importFrom(openxlsx,write.xlsx)
 importFrom(rlang,.data)
 importFrom(shinyalert,shinyalert)
@@ -85,7 +88,5 @@ importFrom(stats,sd)
 importFrom(stats,setNames)
 importFrom(stats,var)
 importFrom(tibble,tribble)
-importFrom(utils,head)
-importFrom(utils,packageVersion)
 importFrom(utils,write.table)
-importFrom(zip,zipr)
+importFrom(yaml,read_yaml)
diff --git a/NEWS.md b/NEWS.md
@@ -7,8 +7,25 @@
 - Add Pandora drat Repo to .Rprofile
 
 ## Bug Fixes
-
 - Fix test in test-downAndUploadModel.R: remove year
+
+# PlotR 23.12.0
+
+## New Features
+- _Import of models_: display of "About" information that is associated to a selected Pandora 
+  Repository
+
+# PlotR 23.09.0
+
+## New Features
+- _Import of models_:
+  - option to import models from Pandora platform
+
+# PlotR 23.08.1
+
+## New Features
+- New UI tab with AIC and BIC information on models + plots
+
 # PlotR 23.08.0
 
 ## Bug Fixes

diff --git a/R/00-NAMESPACE.R b/R/00-NAMESPACE.R
@@ -1,7 +1,7 @@
 #' @import shiny
 #' @importFrom colourpicker colourInput updateColourInput
-#' @importFrom DataTools checkErrorNoNumericColumns checkWarningEmptyValues importDataUI
-#'  importDataServer remoteModelsUI remoteModelsServer tryCatchWithWarningsAndErrors
+#' @importFrom DataTools checkErrorNoNumericColumns checkWarningEmptyValues downloadModelUI
+#'  downloadModelServer importDataUI importDataServer tryCatchWithWarningsAndErrors
 #' @importFrom dplyr bind_cols bind_rows filter mutate
 #' @importFrom DT DTOutput renderDT
 #' @importFrom graphics arrows axis box lines mtext par plot points rect text legend polygon
@@ -15,9 +15,9 @@
 #' @importFrom shinyjs useShinyjs
 #' @importFrom stats cor density dunif na.omit pnorm rnorm rgamma runif sd setNames var median qnorm
 #' @importFrom tibble tribble
-#' @importFrom utils head packageVersion write.table
-#' @importFrom openxlsx read.xlsx write.xlsx
-#' @importFrom zip zipr
+#' @importFrom utils write.table
+#' @importFrom openxlsx write.xlsx
+#' @importFrom yaml read_yaml
 NULL
 
 #' Server and UI Functions for Shiny Module

diff --git a/R/00-config.R b/R/00-config.R
@@ -0,0 +1,9 @@
+#' Config
+#'
+#' @return (list) configuration parameters for import of data and models
+#'
+#' @export
+config <- function() {
+  config_path <- system.file("config.yaml", package = "PlotR")
+  read_yaml(config_path)
+}
diff --git a/R/01-fitModel.R b/R/01-fitModel.R
@@ -144,6 +144,8 @@ fitPlotRModelMC <- function(data,
   res$beta <- do.call("rbind", lapply(1:length(ret), function(x) ret[[x]]$beta))
   res$betaSigma <- do.call("rbind", lapply(1:length(ret), function(x) ret[[x]]$betaSigma))
   res$sigma <- do.call("c", lapply(1:length(ret), function(x) ret[[x]]$sigma))
+  res$llog <- do.call("cbind", lapply(1:length(ret), function(x) ret[[x]]$llog))
+  res$edf <- sum(apply(res$llog,1, var))
   return(res)
 }
 
@@ -193,6 +195,9 @@ fitPlotRModel <- function(data,
 
   lam <- 1E-5
   beta <- rep(0, ncol(XX))
+
+  # Keep current XX in XX2. XX2: matrix on the original X-values
+  # XX will be changed X-values when there is uncertainty
   XX2 <- XX
 
   if (sdVar){
@@ -357,6 +362,7 @@ fitPlotRModel <- function(data,
   #Vektor der tatsaechlich benutzten Beobachtungen
   usedsamples <- seq(from = burnin, to = iter, by = every)
   if (sdVar){
+    # XX2: matrix on the original X-values
     seTotal <- range(sqrt(apply(sapply(1:length(usedsamples), function(x)
       (XX2 %*% betamc[usedsamples[x], ]) * sRe + mRe), 1, var) +
         rowMeans(sapply(1:length(usedsamples), function(x)
@@ -366,12 +372,19 @@ fitPlotRModel <- function(data,
   } else {
     betamcSigma <- NULL
     seTotal <- range(sqrt(apply(sapply(1:length(usedsamples), function(x)
-      (XX %*% betamc[usedsamples[x], ]) * sRe + mRe), 1, var) + mean(smc)))
+      (XX2 %*% betamc[usedsamples[x], ]) * sRe + mRe), 1, var) + mean(smc)))
   }
 
+  llog <- getLLog(matrixDiff = YMean - (XX2 %*% t(betamc[usedsamples, ])),
+                  XX = XX2,
+                  betamcSigma = betamcSigma,
+                  smcSmpls = smc[usedsamples],
+                  sdVar = sdVar)
+
   list(beta = betamc[usedsamples, ], betaSigma = betamcSigma,
        sc = s, sigma = smc[usedsamples, ],
        mRe = mRe, sRe = sRe,
+       llog = llog,
        range = list(mean = range(rowMeans(sapply(1:length(usedsamples), function(x)
          (XX2 %*% betamc[usedsamples[x], ]) * sRe + mRe))),
          se = range(sqrt(apply(sapply(1:length(usedsamples), function(x)
@@ -417,3 +430,22 @@ cpostX <- function(XX,
   #   max = xobs + sqrt(sigma.obs)
   # ))
 }
+
+#' Get LLog
+#'
+#' Log likelihood computation for (W)AIC
+#'
+#' @param matrixDiff (matrix) matrix difference
+#' @param XX (matrix) design matrix
+#' @param betamcSigma (matrix) coefficients of varying standard deviation spline
+#' @param smcSmpls (numeric)  sigmas of MC samples
+#' @param sdVar (logical) TRUE if variable standard deviation
+getLLog <- function(matrixDiff, XX, betamcSigma, smcSmpls, sdVar) {
+  if (sdVar){
+    sigmaMC <- exp((XX %*% t(betamcSigma))) / smcSmpls
+  } else {
+    sigmaMC <- smcSmpls
+  }
+
+  -0.5 * matrixDiff^2 / sigmaMC - 0.5 * log(2*pi) - 0.5 * log(sigmaMC)
+}