Initial commit

.gitattributes

@@ -0,0 +1,2 @@
+# Auto detect text files and perform LF normalization
+* text=auto

DESCRIPTION

@@ -0,0 +1,29 @@
+Package: shinyMixR
+Title: Shiny dashboard interface for nlmixr
+Version: 0.1.1
+Authors@R: c(person("Richard", "Hooijmaijers", email = "richardhooijmaijers@gmail.com", role = c("aut", "cre","cph")),
+             person("Teun", "Post", email = "teunpost@gmail.com",role = c("aut","cph")),
+             person("LAPP Consultants",email = "info@lapp.nl", role=c("fnd","cph")),
+             person("Matthew Fidler",role=c("ctb")))
+Description: The package is developed as an interface for the nlmixr package. Furthermore additional functions
+  are included to work with the nlmixr package through the command line
+Depends:
+  R (>= 3.4.0),
+  shiny,
+  shinyBS,
+  nlmixr,
+  ggplot2
+Imports:
+  gridExtra,
+  collapsibleTree,
+  shinyAce,
+  DT,
+  xpose,
+  xpose.nlmixr,
+  shinydashboard,
+  stringi,
+  R3port
+License: MIT+LICENSE
+Encoding: UTF-8
+LazyData: true
+RoxygenNote: 6.0.1

LICENSE

@@ -0,0 +1,2 @@
+YEAR: 2018
+COPYRIGHT HOLDER: Richard Hooijmaijers, Teun Post, LAP&P Consultants

NAMESPACE

@@ -0,0 +1,40 @@
+# Generated by roxygen2: do not edit by hand
+
+export(adaptModel)
+export(adaptOverview)
+export(adpt_meta)
+export(changeResults)
+export(createRunScript)
+export(create_proj)
+export(duplModelModal)
+export(duplModelSave)
+export(editUI)
+export(fitPlot)
+export(fitUI)
+export(fit_plot)
+export(get_proj)
+export(gofPlot)
+export(gofUI)
+export(gof_plot)
+export(incr_mdl)
+export(modProgr)
+export(newModelModal)
+export(newModelSave)
+export(overview)
+export(overviewUI)
+export(parTable)
+export(par_table)
+export(partableUI)
+export(refreshResults)
+export(resUI)
+export(runMod)
+export(runUI)
+export(run_nmx)
+export(run_shinymixr)
+export(saveModel)
+export(scriptsUI)
+export(showResults)
+export(tree_overview)
+export(udpateResultList)
+export(updateEditList)
+export(updateRunInputs)

R/adpt_meta.r

@@ -0,0 +1,34 @@
+#------------------------------------------ adpt_meta ------------------------------------------
+#' Adapt meta information inside a nlmixr UIF
+#'
+#' regular expressions are used to search for meta data inside a model
+#' file. This meta data is then updated with the provided new values
+#'
+#' @param mdl character with the name of the model to adapt
+#' @param newvals list with characteristics/meta data to adapt
+#'
+#' @export
+#' @return character vector with model including the adapted meta data
+#' @author Richard Hooijmaijers
+#' @examples
+#'
+#' \dontrun{
+#'   adpt_meta("model.r",newvals=list(imp=4,ref="run 1"))
+#' }
+adpt_meta <- function(mdl,newvals){
+  fenv <- environment()
+  mdlt <- readLines(mdl)
+  lapply(1:length(newvals),function(x){
+    taga <- ifelse(names(newvals)[x]%in%c("desc","data","ref","est"),"[\"|'].*[\"|']","[[:digit:]]")
+    sstr <- paste0(names(newvals)[x],".*",taga)
+    gstr <- regexpr(sstr,mdlt)
+    # only adapt first occurence [1]
+    gstr <- c(which(gstr>1)[1],gstr[which(gstr>1)][1],attr(gstr,'match.length')[which(gstr>1)[1]])
+    if(!any(is.na(gstr))){
+      ret <- paste(names(newvals)[x],"=",ifelse(names(newvals)[x]=="imp",newvals[x],paste0("\"",newvals[x],"\"")))
+      mdlt[gstr[1]] <- gsub(substr(mdlt[gstr[1]],gstr[2],gstr[3]+gstr[2]-1),ret,mdlt[gstr[1]])
+    }
+    assign("mdlt",mdlt,envir = fenv)
+  })
+  return(mdlt)
+}

R/create_proj.r

@@ -0,0 +1,26 @@
+#------------------------------------------ create_proj ------------------------------------------
+#' Creates a new project
+#'
+#' Creates a new project which basically means that within the specified folder,
+#' the necessary folder structure will be created and some example models will be placed in it.
+#'
+#' @param loc character with the location where the project should be created
+#'
+#' @return nothing will be returned by the function (only system commands are issued)
+#' @author Richard Hooijmaijers
+#' @export
+#' @examples
+#'
+#' \dontrun{
+#'  create_proj()
+#' }
+create_proj <- function(loc="."){
+  # First create the folder structure
+  dirs <- paste0(loc,c("/analysis","/data","/models","/shinyMixR","/scripts"))
+  sapply(dirs,dir.create,showWarnings = FALSE)
+  # Now place in some default models and data
+  file.copy(paste0(system.file(package = "shinyMixR"),"/Other/run1.r"),paste0(loc,"/models/run1.r"))
+  file.copy(paste0(system.file(package = "shinyMixR"),"/Other/run2.r"),paste0(loc,"/models/run2.r"))
+  file.copy(paste0(system.file(package = "shinyMixR"),"/Other/theo_sd.rds"),paste0(loc,"/data/theo_sd.rds"))
+  file.copy(paste0(system.file(package = "shinyMixR"),"/Other/eta.plot.r"),paste0(loc,"/scripts/eta.plot.r"))
+}

R/fit_plot.r

@@ -0,0 +1,46 @@
+#------------------------------------------ fit_plot ------------------------------------------
+#' Create fit plot
+#'
+#' Creates a fit plot either using the xpose.nlmixr package or using a
+#' default ggplot call
+#'
+#' @param dfrm data frame as created by the nlmixr function
+#' @param type character defining the type of plot that should be created. currently
+#'   "xpose" and "user" are supported for xpose or ggplot style of plots
+#' @param mdlnm character with name of the model
+#' @param outnm character with name of the output file (see details)
+#' @param ... additional arguments passed to \code{\link[R3port]{ltx_plot}} or \code{\link[R3port]{html_plot}}
+#'
+#' @details In case a model is saved, a directory with the name of the model is created within the
+#'   analysis folder of the current project. Then within this folder the file is saved as outnm.
+#'   This method was chosen so the interface can easily index applicable files for a certain model.
+#'   However, this means that output is alwasy saved in this directly regardless of the location of outnm
+#'
+#' @export
+#' @return in case no outnm is defined a ggplot object will be returned otherwise
+#'   the results are saved to disk
+#'
+#' @author Richard Hooijmaijers
+#' @examples
+#'
+#' \dontrun{
+#'  fit_plot(res)
+#' }
+fit_plot <- function(dfrm,type="xpose",mdlnm=NULL,outnm=NULL,...){
+  if(type=="xpose"){
+    xpdb <- xpose.nlmixr::xpose_data_nlmixr(dfrm)
+    pl   <- xpose::ind_plots(xpdb, nrow=3, ncol=4)
+  }else if(type=="user"){
+    pl   <- ggplot(dfrm,aes(x=TIME)) + geom_point(aes(y=DV)) +
+              geom_line(aes(y=PRED)) + geom_line(aes(y=IPRED),linetype=2) +
+              facet_wrap(~ID)
+  }
+  if(is.null(outnm)){
+    pl
+  }else{
+    if(is.null(mdlnm)) stop("in case output should be saved, mdlnm should be given")
+    dir.create(paste0("./analysis/",mdlnm),showWarnings=FALSE)
+    if(grepl("\\.tex$",outnm)) R3port::ltx_plot(pl,out=paste0("./analysis/",mdlnm,"/",basename(outnm)),...)
+    if(grepl("\\.html$",outnm)) R3port::html_plot(pl,out=paste0("./analysis/",mdlnm,"/",basename(outnm)),...)
+  }
+}

R/get_proj.r

@@ -0,0 +1,89 @@
+#------------------------------------------ get_proj ------------------------------------------
+#' Read in and update model results in project object
+#'
+#' This function creates or updates a project object with models and/or results emerged from nlmixr runs
+#' A check is performed to see if newer results are present and only updates these.
+#'
+#' @param moddir character with the directory that includes the model files
+#' @param proj character with the rds files that includes the model information
+#'
+#' @export
+#' @examples
+#'
+#' \dontrun{
+#'   proj <- get_proj()
+#' }
+get_proj <- function(moddir="./models",proj="./shinyMixR/project.rds",datdir="./data",geteval=TRUE){
+  # Read in models and place in result objects
+  dir.create(dirname(proj),showWarnings = FALSE,recursive = TRUE)
+  mdln    <- normalizePath(list.files(moddir,pattern="run[[:digit:]]*\\.[r|R]",full.names = TRUE))
+  sumres  <- normalizePath(list.files("shinyMixR",pattern="run[[:digit:]]*\\.ressum\\.rds",full.names = TRUE))
+  sumresi <- file.info(sumres)
+  summdli <- file.info(mdln)
+
+  # read in data folder (only in case objects are not yet present)
+  datf  <- list.files(datdir)
+  grepd <- " |^[[:digit:]]|\\!|\\#|\\$|\\%|\\&|\\'|\\(|\\)|\\-|\\;|\\=|\\@|\\[|\\]|\\^\\`\\{\\|\\}"
+  if(any(grepl(grepd,datf))) warning("Data files with special characters found, take into acount that models that use these can crash")
+  lapply(list.files(datdir,full.names = TRUE),function(x){
+    if(!grepl(grepd,x) & !exists(sub("\\.rds$","",basename(x)),envir=.GlobalEnv)){
+      assign(sub("\\.rds$","",basename(x)),readRDS(x),pos = .GlobalEnv)
+    }
+  })
+
+  # Read in models and results
+  if(!file.exists(proj)){
+    mdls <- lapply(mdln,list)
+    names(mdls) <- sub("\\.[r|R]","",basename(mdln))
+    if(length(mdln)==0){
+      warning("No models present")
+    }else{
+      for(i in 1:length(mdln)){
+        names(mdls[[i]]) <- "model"
+        if(geteval) mdls[[i]]$modeleval <- eval(parse(text=c("try(nlmixrUI(",readLines(mdln[i]),"))")))
+      }
+    }
+    for(i in sumres) mdls[[sub("\\.ressum\\.rds","",basename(i))]]$results <- readRDS(i)
+    mdls$meta <- list(lastrefresh=Sys.time())
+  }else{
+    mdls   <- readRDS(proj)
+    # for the list with models, check if new models are available or old models are deleted
+    # and if models are updated after last refresh:
+    inproj <- unlist(sapply(mdls[names(mdls)[names(mdls)!="meta"]],"[",1))
+    todel  <- setdiff(inproj,mdln)
+    toadd  <- setdiff(mdln,inproj)
+    if(length(todel)!=0){
+      themods <- sapply(mdls[names(mdls)[names(mdls)!="meta"]],function(x) x$model%in%todel)
+      mdls <- mdls[c(sort(names(themods[!themods])),"meta")]
+    }
+    if(length(toadd)!=0){
+      mdls2 <- lapply(toadd,list)
+      names(mdls2) <- sub("\\.[r|R]","",basename(toadd))
+      for(i in 1:length(mdls2)){
+        names(mdls2[[i]]) <- "model"
+        if(geteval) mdls2[[i]]$modeleval <- eval(parse(text=c("try(nlmixrUI(",readLines(toadd[i]),"))")))
+      }
+      mdls <- c(mdls,mdls2)
+    }
+    if(geteval){
+      for(i in mdln){
+        if(summdli$mtime[row.names(summdli)==i] > mdls$meta$lastrefresh)
+          mdls[[sub("\\.[r|R]","",basename(i))]]$modeleval <- eval(parse(text=c("try(nlmixrUI(",readLines(i),"))")))
+      }
+    }
+    # For model results, check if there are newer results than time of last save
+    for(i in sumres){
+      if(sumresi$mtime[row.names(sumresi)==i] > mdls$meta$lastrefresh)
+        mdls[[sub("\\.ressum\\.rds","",basename(i))]]$results <- readRDS(i)
+    }
+    mdls$meta$lastrefresh <- Sys.time()
+  }
+  # Additional check to see if model is not saved after the last results
+  chk       <- data.frame(mdl=sub("\\.[r|R]","",basename(mdln)),mdlsv=summdli$mtime,stringsAsFactors = FALSE)
+  chk$ressv <- sumresi$mtime[match(chk$mdl,sub("\\.ressum\\.rds","",basename(sumres)))]
+  chk       <- chk[which(chk$mdlsv>chk$ressv),]
+  #if(nrow(chk)>0) noret <- apply(chk,1,function(x) cat("Be aware that model is saved after results for",x['mdl'],"\n"))
+
+  saveRDS(mdls,file=proj)
+  return(mdls)
+}

R/gof_plot.r

@@ -0,0 +1,55 @@
+#------------------------------------------ gof_plot ------------------------------------------
+#' Create goodness of fit plots
+#'
+#' Creates goodness of fit plots either using the xpose.nlmixr package or using a
+#' default ggplot call
+#'
+#' @param dfrm data frame as created by the nlmixr function
+#' @param type character defining the type of plot that should be created. currently
+#'   "xpose" and "user" are supported for xpose or ggplot style of plots
+#' @param mdlnm character with name of the model
+#' @param outnm character with name of the output file (see details)
+#' @param ... additional arguments passed to \code{\link[R3port]{ltx_plot}} or \code{\link[R3port]{html_plot}}
+#'
+#' @details In case a model is saved, a directory with the name of the model is created within the
+#'   analysis folder of the current project. Then within this folder the file is saved as outnm.
+#'   This method was chosen so the interface can easily index applicable files for a certain model.
+#'   However, this means that output is alwasy saved in this directly regardless of the location of outnm
+#'
+#' @export
+#' @return in case no outnm is defined a ggplot object will be returned otherwise
+#'   the results are saved to disk
+#'
+#' @author Richard Hooijmaijers
+#' @examples
+#'
+#' \dontrun{
+#'  gof_plot(res)
+#' }
+gof_plot <- function(dfrm,type="xpose",mdlnm=NULL,outnm=NULL,...){
+  if(type=="xpose"){
+    xpdb <- xpose.nlmixr::xpose_data_nlmixr(dfrm)
+    p1   <- xpose::dv_vs_pred(xpdb)
+    p2   <- xpose::dv_vs_ipred(xpdb)
+    p3   <- xpose::res_vs_pred(xpdb)
+    p4   <- xpose::res_vs_idv(xpdb)
+  }else if(type=="user"){
+    p1  <- ggplot(dfrm,aes(DV,PRED)) + geom_point(alpha=.6)  + geom_abline(intercept=0,slope=1,colour="darkblue",linetype=2)
+    p2  <- ggplot(dfrm,aes(DV,IPRED)) + geom_point(alpha=.6) + geom_abline(intercept=0,slope=1,colour="darkblue",linetype=2)
+    p3  <- ggplot(dfrm,aes(TIME,CWRES)) + geom_point(alpha=.6) + geom_hline(yintercept=0,colour="darkblue",linetype=2)
+    p4  <- ggplot(dfrm,aes(PRED,CWRES)) + geom_point(alpha=.6) + geom_hline(yintercept=0,colour="darkblue",linetype=2)
+  }
+  if(is.null(outnm)){
+    gridExtra::grid.arrange(p1+ggtitle("A"),p2+ggtitle("B"),p3+ggtitle("C"),p4+ggtitle("D"))
+  }else{
+    if(is.null(mdlnm)) stop("in case output should be saved, mdlnm should be given")
+    dir.create(paste0("./analysis/",mdlnm),showWarnings=FALSE)
+    if(grepl("\\.tex$",outnm)){
+      R3port::ltx_plot(gridExtra::grid.arrange(p1+ggtitle("A"),p2+ggtitle("B"),p3+ggtitle("C"),p4+ggtitle("D")),
+                       out=paste0("./analysis/",mdlnm,"/",basename(outnm)),...)
+    }else if(grepl("\\.html$",outnm)){
+      R3port::html_plot(gridExtra::grid.arrange(p1+ggtitle("A"),p2+ggtitle("B"),p3+ggtitle("C"),p4+ggtitle("D")),
+                        out=paste0("./analysis/",mdlnm,"/",basename(outnm)),...)
+    }
+  }
+}

R/incr_mdl.r

@@ -0,0 +1,53 @@
+#------------------------------------------ incr_mdl ------------------------------------------
+#' Increments a model name
+#'
+#' A model name is incremented either by incementing numerical or alpha numerical.
+#' Furthermore it is possible to check the existence of the incremented model
+#' and take this into account.
+#'
+#' @param mod character with the model name
+#' @param checkloc character with the location to check for existence of a file
+#'
+#' @export
+#' @return character with the incremented name
+#' @author Richard Hooijmaijers
+#' @examples
+#'
+#'  incr_mdl("run01.r")
+incr_mdl <- function(mod,checkloc=NULL){
+
+  name_func <- function(mdl=mod){
+    mod2 <- substring(mdl,1,tail(gregexpr("\\.",mdl)[[1]],1)-1) # delete extension!
+    if(suppressWarnings(is.na(as.numeric(substring(mod2,nchar(mod2)))))){
+      # In case of character
+      if(toupper(substring(mod2,nchar(mod2)))=="Z"){
+        paste0(mod2,"a")
+      }else{
+        firstp <- substring(mod2,1,nchar(mod2)-1)
+        lastp  <- c(letters,LETTERS)[grep(substring(mod2,nchar(mod2)),c(letters,LETTERS)) + 1]
+        ret    <- paste0(firstp,lastp)
+      }
+    }else{
+      # In case of numeric
+      nfmt <- regexpr("[[:digit:]]*$",mod2)
+      num  <- substring(mod2,nfmt[1],attr(nfmt,"match.length")+nfmt[1])
+      num  <- formatC(as.numeric(num)+1,width=attr(nfmt,"match.length"),flag="0")
+      ret  <- paste0(substring(mod2,1,nfmt[1]-1),num)
+    }
+    paste0(ret,substring(mdl,tail(gregexpr("\\.",mdl)[[1]],1)))
+  }
+  # If there is a checkloc the function is repeated until a non existing filename is present (or after 500 repeats)
+  if(!is.null(checkloc)){
+    ret   <- name_func()
+    maxtr <- 500
+    tryn  <- 1
+    while(file.exists(paste0(checkloc,"/",ret))){
+      ret  <- name_func(mdl=ret)
+      tryn <- tryn+1
+      if(tryn>maxtr) break
+    }
+    ret
+  }else{
+     name_func()
+  }
+}