Fixed Various Issues

- Fixed Issue with AET parameter for M4 models - Corrected create_dependecy_list function issue with respect to MRTIVIFOi and MRTIVIFPi - Accounted for AUCLAST to output 0 if all concentrations are 0 - Accouned for AUCINFP to output NA if all concentrations are 0 - Corrected logic for parameter_required function - Fixed various issues with error checks - Removed logic for FLGACCEPTTAU from M4 models - Fixed other minor issues
tensfeldt · Jan 30, 2020 · a6cb6ff · a6cb6ff
1 parent b9858f9
commit a6cb6ff
Show file tree

Hide file tree

Showing 18 changed files with 497 additions and 440 deletions.
diff --git a/openNCA/R/aet.R b/openNCA/R/aet.R
@@ -143,7 +143,7 @@ aet <- function(amt = NULL, time = NULL, t = NULL, orig_time=NULL, all_time=NULL
           a_e <- ifelse(a_e == 0, NA, a_e)
         }
       } else {
-        tmp_rows <- unlist(sapply(all_time, function(x){ x %in% orig_time }))
+        tmp_rows <- unlist(sapply(all_time, function(x){ all(x %in% orig_time) }))
         tmp_end_time <- all_time[tmp_rows,][,2]
         tmp_time <- end_time %in% tmp_end_time
         tmp_lim <- seq(1:length(tmp_time))[tmp_time]

diff --git a/openNCA/R/auc_inf_p.R b/openNCA/R/auc_inf_p.R
@@ -178,7 +178,7 @@ auc_inf_p <- function(conc = NULL, time = NULL, method = 1, kelflag = NULL, aucf
     t_last <- tlast(conc = conc, time = time)
   }
   if(sum(conc, na.rm = T) == 0){
-    return(0)
+    return(NA)
   }
 
   if(is.na(kel[['KEL']])){

diff --git a/openNCA/R/auc_last.R b/openNCA/R/auc_last.R
@@ -171,6 +171,9 @@ auc_last <- function(conc = NULL, time = NULL, method = 1, exflag = NULL, t_last
   if(length(time) == 0 || length(conc) == 0 || all(is.na(time)) || all(is.na(conc))) { 
     return(NA)
   }
+  if(sum(conc, na.rm = T) == 0){
+    return(0)
+  }
 
   #Formatting data to subset data based on time values
   if(is.null(t_last)){
@@ -190,9 +193,6 @@ auc_last <- function(conc = NULL, time = NULL, method = 1, exflag = NULL, t_last
   if(length(time) != length(conc)){
     stop("Error in auc_last: length of 'time' and 'conc' vectors are not equal")
   }
-  if(sum(conc, na.rm = T) == 0){
-    return(0)
-  }
 
   if(method == 1){
     return(auc_lin_log(conc = conc, time = time, exflag = exflag, t_max = t_max))

diff --git a/openNCA/R/create_dependency_list.R b/openNCA/R/create_dependency_list.R
@@ -215,9 +215,9 @@ create_dependency_list <- function() {
     dependency_list[["MRTEVIFP"]] <- list(callfun=c(), regex="^MRTEVIFP$", unit_class=c(uclass_time), valid_models=c(m1sd), display_list_models=c(), predecessors=c("AUCINFP", "AUMCINFP"))
     dependency_list[["MRTEVIFPi"]] <- list(callfun=c(), regex="^MRTEVIFP(i{1}?|[0-9]+?)$", unit_class=c(uclass_time), valid_models=c(m1ss), display_list_models=c(), predecessors=c("AUCINFPi", "AUCTAUi", "AUMCTAUi", "TAUi", "TOLDi"))
     dependency_list[["MRTIVIFO"]] <- list(callfun=c(), regex="^MRTIVIFO$", unit_class=c(uclass_time), valid_models=c(m2sd, m3sd), display_list_models=c(), predecessors=c("AUCINFO", "AUMCINFO"))
-    dependency_list[["MRTIVIFOi"]] <- list(callfun=c(), regex="^MRTIVIFO(i{1}?|[0-9]+?)$", unit_class=c(uclass_time), valid_models=c(m2ss, m3ss), display_list_models=c(), predecessors=c("TAUi", "TOLDi"))
+    dependency_list[["MRTIVIFOi"]] <- list(callfun=c(), regex="^MRTIVIFO(i{1}?|[0-9]+?)$", unit_class=c(uclass_time), valid_models=c(m2ss, m3ss), display_list_models=c(), predecessors=c("AUCINFOi", "AUMCINFOi", "AUCTAUi", "AUMCTAUi", "TAUi", "TOLDi"))
     dependency_list[["MRTIVIFP"]] <- list(callfun=c(), regex="^MRTIVIFP$", unit_class=c(uclass_time), valid_models=c(m2sd, m3sd), display_list_models=c(m3sd, m3sd), predecessors=c("AUCINFP", "AUMCINFP"))
-    dependency_list[["MRTIVIFPi"]] <- list(callfun=c(), regex="^MRTIVIFP(i{1}?|[0-9]+?)$", unit_class=c(uclass_time), valid_models=c(m2ss, m3ss), display_list_models=c(m3ss, m3ss), predecessors=c("TAUi", "TOLDi"))
+    dependency_list[["MRTIVIFPi"]] <- list(callfun=c(), regex="^MRTIVIFP(i{1}?|[0-9]+?)$", unit_class=c(uclass_time), valid_models=c(m2ss, m3ss), display_list_models=c(m3ss, m3ss), predecessors=c("AUCINFPi", "AUMCINFPi", "AUCTAUi", "AUMCTAUi", "TAUi", "TOLDi"))
     dependency_list[["MRTLAST"]] <- list(callfun=c(), regex="^MRTLAST$", unit_class=c(uclass_time), valid_models=c(m1, m2, m3), display_list_models=c(m3sd, m3ss), predecessors=c("AUCLAST", "AUMCLAST"))
     dependency_list[["MRTLASTi"]] <- list(callfun=c(), regex="^MRTLAST(i{1}?|[0-9]+?)$", unit_class=c(uclass_time), valid_models=c(m1ss, m2ss, m3ss), display_list_models=c(), predecessors=c("AUCLASTi", "AUMCLASTi", "TAUi", "TOLDi"))
     dependency_list[["PTF"]] <- list(callfun=c(), regex="^PTF$", unit_class=c(uclass_ratio), valid_models=c(m1ss, m2ss, m3ss), display_list_models=c(m1ss), predecessors=c("CMAX", "CMIN", "CAV", "TAUi", "TOLDi"))

diff --git a/openNCA/R/dosec.R b/openNCA/R/dosec.R
@@ -73,7 +73,16 @@ dosec <- function(data = NULL, map = NULL, idose = NULL){
 ##  }
 
   ### Create a pseudo results (resulting parameters) dataset to drive unit_conversion
-  vlist <- c(map_data$CONCU, xdoseu, xdose)
+  vlist <- c()
+  if(!is.na(map_data$CONCU)){
+    vlist <- c(vlist, map_data$CONCU)
+  }
+  if(!is.na(xdoseu)){
+    vlist <- c(vlist, xdoseu)
+  }
+  if(!is.na(xdose)){
+    vlist <- c(vlist, xdose)
+  }
 ##  vlist <- c(map_tc12$SDEID, map_data$CONCU)
 ##  if(!is.null(xdoseu)){
 ##    vlist <- c(vlist, xdoseu)
@@ -82,16 +91,19 @@ dosec <- function(data = NULL, map = NULL, idose = NULL){
 ##    vlist <- c(vlist, xdose)
 ##  }
   vlist <- unlist(vlist)
-
-  data_data <- data_data[!duplicated(data_data[,xdose]), vlist]
+  if(!is.na(xdose) && xdose %in% names(data_data) && length(vlist) > 0){
+    data_data <- data_data[!duplicated(data_data[,xdose]), vlist]
 ##  if(!is.null(xdose) && all(xdose %in% names(data_data)) && all(vlist %in% names(data_data))){
 ##    data_data <- data_data[!duplicated(data_data[,xdose]), vlist] 
 ##  } else {
 ##    data_data <- data_data[, vlist]
 ##  }
 
-  df <- unit_conversion(data = data_data, map = map_data, result = data_data, unit_class = "DOSEU", verbose=FALSE)
-  dose_c <- df[,xdose]
+    df <- unit_conversion(data = data_data, map = map_data, result = data_data, unit_class = "DOSEU", verbose=FALSE)
+    dose_c <- df[,xdose]
+  } else {
+    dose_c <- NA
+  }
 
   return(dose_c)
 }
diff --git a/openNCA/R/parameter_required.R b/openNCA/R/parameter_required.R
@@ -76,8 +76,7 @@
 #' @export
 parameter_required <- function(parameter_names, parameter_list, simplify=TRUE) {
   k <- parameter_indices(parameter_names, parameter_list, simplify = simplify)
-  k <- lapply(k, FUN=function(x) { length(x)>0 } )
-
+  k <- lapply(k, FUN=function(x) { length(x)>0 & !is.na(x) } )
   if(length(k)==0) { return(FALSE) }
 
   if(simplify) { result <- all(unlist(k)) }

diff --git a/openNCA/R/run_M1_SD_computation.R b/openNCA/R/run_M1_SD_computation.R
@@ -811,11 +811,15 @@ run_M1_SD_computation <- function(data = NULL, map = NULL, method = 1, model_reg
   }
 ##  2019-11-08/RD Added for Interpolation to account for error handling
 ##
-  if("INCLUDEINTERPOLATION" %in% names(map_data) && (map_data[, "INCLUDEINTERPOLATION"] != 0 && map_data[, "INCLUDEINTERPOLATION"] != 1)){
-    warning("Flag 'INCLUDEINTERPOLATION' does not have a valid value! Please try again with numeric value (either 0 or 1)")
+  if("INCLUDEINTERPOLATION" %in% names(map_data)){
+    if(isTRUE(map_data[, "INCLUDEINTERPOLATION"] != 0 && map_data[, "INCLUDEINTERPOLATION"] != 1)){
+      warning("Flag 'INCLUDEINTERPOLATION' does not have a valid value! Please try again with numeric value (either 0 or 1)")
+    }
   }
-  if("INCLUDEEXTRAPOLATION" %in% names(map_data) && (map_data[, "INCLUDEEXTRAPOLATION"] != 0 && map_data[, "INCLUDEEXTRAPOLATION"] != 1)){
-    warning("Flag 'INCLUDEEXTRAPOLATION' does not have a valid value! Please try again with numeric value (either 0 or 1)")
+  if("INCLUDEEXTRAPOLATION" %in% names(map_data)){
+    if(isTRUE(map_data[, "INCLUDEEXTRAPOLATION"] != 0 && map_data[, "INCLUDEEXTRAPOLATION"] != 1)){
+      warning("Flag 'INCLUDEEXTRAPOLATION' does not have a valid value! Please try again with numeric value (either 0 or 1)")
+    }
   }
   #if((!"LLOQPATTERNS" %in% names(map_data)) && generate_nominal_conc){
   #  warning("Flag 'LLOQPATTERNS' is not present in the map dataset")
@@ -848,39 +852,55 @@ run_M1_SD_computation <- function(data = NULL, map = NULL, method = 1, model_reg
       tmp_df[,map_data$CONC] <- as.numeric(tmp_df[,map_data$CONC])
       tmp_df[,map_data$TIME] <- as.numeric(tmp_df[,map_data$TIME])
 
-      tmp_kel_flg <- as.numeric(tmp_df[,map_data$FLGEXKEL])
-      if("FLGEXSDE" %in% names(map_data) && map_data$FLGEXSDE %in% names(data_data)){
-        ex_flag <- as.numeric(tmp_df[,map_data$FLGEXSDE])
-        if(all(is.na(ex_flag))){
-          ex_flag[is.na(ex_flag)] <- 0
+      if("FLGEXSDE" %in% names(map_data)) {
+        if(map_data$FLGEXSDE %in% names(data_data)){
+          ex_flag <- as.numeric(tmp_df[,map_data$FLGEXSDE])
+          if(all(is.na(ex_flag))){
+            ex_flag[is.na(ex_flag)] <- 0
+          }
+          tmp_df <- tmp_df[!as.logical(ex_flag),]
+        } else {
+          ex_flag <- NULL
         }
-        tmp_df <- tmp_df[!as.logical(ex_flag),]
       } else {
         ex_flag <- NULL
       }
-      if("FLGEXKEL" %in% names(map_data) && map_data$FLGEXKEL %in% names(data_data)){
-        kel_flag <- as.numeric(tmp_df[,map_data$FLGEXKEL])
-        if(all(is.na(kel_flag))){
-          kel_flag[is.na(kel_flag)] <- 0
-        }
-        if(isTRUE(optimize_kel)){
-          kel_flag <- rep(1, length(tmp_kel_flg))
+      if("FLGEXKEL" %in% names(map_data)) {
+        if(map_data$FLGEXKEL %in% names(data_data)){
+          tmp_kel_flg <- as.numeric(tmp_df[,map_data$FLGEXKEL])
+          kel_flag <- as.numeric(tmp_df[,map_data$FLGEXKEL])
+          if(all(is.na(kel_flag))){
+            kel_flag[is.na(kel_flag)] <- 0
+          }
+          if(isTRUE(optimize_kel)){
+            kel_flag <- rep(1, length(tmp_kel_flg))
+          }
+        } else {
+          kel_flag <- NULL
         }
       } else {
         kel_flag <- NULL
       }
-      if("FLGEXAUC" %in% names(map_data) && map_data$FLGEXAUC %in% names(data_data)){
-        auc_flag <- as.numeric(tmp_df[,map_data$FLGEXAUC])
-        if(all(is.na(auc_flag))){
-          auc_flag[is.na(auc_flag)] <- 0
+      if("FLGEXAUC" %in% names(map_data)) {
+        if(map_data$FLGEXAUC %in% names(data_data)){
+          auc_flag <- as.numeric(tmp_df[,map_data$FLGEXAUC])
+          if(all(is.na(auc_flag))){
+            auc_flag[is.na(auc_flag)] <- 0
+          }
+        } else {
+          auc_flag <- NULL
         }
       } else {
         auc_flag <- NULL
       }
-      if("FLGEMESIS" %in% names(map_data) && map_data$FLGEMESIS %in% names(data_data)){
-        emesis_flag <- as.numeric(tmp_df[,map_data$FLGEMESIS])
-        if(all(is.na(emesis_flag))){
-          emesis_flag[is.na(emesis_flag)] <- 0
+      if("FLGEMESIS" %in% names(map_data)) {
+        if(map_data$FLGEMESIS %in% names(data_data)){
+          emesis_flag <- as.numeric(tmp_df[,map_data$FLGEMESIS])
+          if(all(is.na(emesis_flag))){
+            emesis_flag[is.na(emesis_flag)] <- 0
+          }
+        } else {
+          emesis_flag <- NULL
         }
       } else {
         emesis_flag <- NULL
@@ -1360,13 +1380,13 @@ run_M1_SD_computation <- function(data = NULL, map = NULL, method = 1, model_reg
 ###        if(parameter_required("^MRTEVIFO(i)*?$", parameter_list) || length(dependent_parameters("^MRTEVIFO(i)*?$"))>0) {
 ###        if(comp_required[["MRTEVIFOi"]]) {
         if(comp_required[["MRTEVIFO"]]) {
-          mrto <- mrt_evif_o(conc = tmp_df[,map_data$CONC], time = tmp_df[,map_data$TIME], method = method, parameter = "SD", kelflag = kel_flag, aucflag = auc_flag)
+          mrto <- mrt_evif_o(conc = tmp_df[,map_data$CONC], time = tmp_df[,map_data$TIME], method = method, parameter = "SD", kelflag = kel_flag, aucflag = auc_flag, aucinfo = aucinf_o, aumcinfo = aumcinf_o)
         }
 ###        if("MRTEVIFP" %in% parameter_list){
 ###        if(parameter_required("^MRTEVIFP(i)*?$", parameter_list) || length(dependent_parameters("^MRTEVIFP(i)*?$"))>0) {
 ###        if(comp_required[["MRTEVIFPi"]]) {
         if(comp_required[["MRTEVIFP"]]) {
-          mrtp <- mrt_evif_p(conc = tmp_df[,map_data$CONC], time = tmp_df[,map_data$TIME], method = method, parameter = "SD", kelflag = kel_flag, aucflag = auc_flag)
+          mrtp <- mrt_evif_p(conc = tmp_df[,map_data$CONC], time = tmp_df[,map_data$TIME], method = method, parameter = "SD", kelflag = kel_flag, aucflag = auc_flag, aucinfp = aucinf_p, aumcinfp = aumcinf_p)
         }
 ###        if("AUCXPCTO" %in% parameter_list){
         if(comp_required[["AUCXPCTO"]]) {

diff --git a/openNCA/R/run_M1_SS_computation.R b/openNCA/R/run_M1_SS_computation.R
@@ -1044,11 +1044,15 @@ run_M1_SS_computation <- function(data = NULL, map = NULL, method = 1, model_reg
   }
 ##  2019-11-08/RD Added for Interpolation to account for error handling
 ##
-  if("INCLUDEINTERPOLATION" %in% names(map_data) && (map_data[, "INCLUDEINTERPOLATION"] != 0 && map_data[, "INCLUDEINTERPOLATION"] != 1)){
-    warning("Flag 'INCLUDEINTERPOLATION' does not have a valid value! Please try again with numeric value (either 0 or 1)")
+  if("INCLUDEINTERPOLATION" %in% names(map_data)){
+    if(isTRUE(map_data[, "INCLUDEINTERPOLATION"] != 0 && map_data[, "INCLUDEINTERPOLATION"] != 1)){
+      warning("Flag 'INCLUDEINTERPOLATION' does not have a valid value! Please try again with numeric value (either 0 or 1)")
+    }
   }
-  if("INCLUDEEXTRAPOLATION" %in% names(map_data) && (map_data[, "INCLUDEEXTRAPOLATION"] != 0 && map_data[, "INCLUDEEXTRAPOLATION"] != 1)){
-    warning("Flag 'INCLUDEEXTRAPOLATION' does not have a valid value! Please try again with numeric value (either 0 or 1)")
+  if("INCLUDEEXTRAPOLATION" %in% names(map_data)){
+    if(isTRUE(map_data[, "INCLUDEEXTRAPOLATION"] != 0 && map_data[, "INCLUDEEXTRAPOLATION"] != 1)){
+      warning("Flag 'INCLUDEEXTRAPOLATION' does not have a valid value! Please try again with numeric value (either 0 or 1)")
+    }
   }
   #if((!"LLOQPATTERNS" %in% names(map_data)) && generate_nominal_conc){
   #  warning("Flag 'LLOQPATTERNS' is not present in the map dataset")
@@ -1316,39 +1320,55 @@ run_M1_SS_computation <- function(data = NULL, map = NULL, method = 1, model_reg
 ###      vlist <- c("PKDATAROWID", "SDEID", "SUBJID", map_data$TIME, map_data$NOMTIME, map_data$ACTTIME, map_data$CONC, map_data$TOLD1, map_data$TAU1, map_data$TOLD2, map_data$TAU2, "DI1F", "DI2F")
 ###      if(i==1) {       print(tmp_df[,vlist]) }
 
-      tmp_kel_flg <- as.numeric(tmp_df[,map_data$FLGEXKEL])
-      if("FLGEXSDE" %in% names(map_data) && map_data$FLGEXSDE %in% names(data_data)){
-        ex_flag <- as.numeric(tmp_df[,map_data$FLGEXSDE])
-        if(all(is.na(ex_flag))){
-          ex_flag[is.na(ex_flag)] <- 0
+      if("FLGEXSDE" %in% names(map_data)) {
+        if(map_data$FLGEXSDE %in% names(data_data)){
+          ex_flag <- as.numeric(tmp_df[,map_data$FLGEXSDE])
+          if(all(is.na(ex_flag))){
+            ex_flag[is.na(ex_flag)] <- 0
+          }
+          tmp_df <- tmp_df[!as.logical(ex_flag),]
+        } else {
+          ex_flag <- NULL
         }
-        tmp_df <- tmp_df[!as.logical(ex_flag),]
       } else {
         ex_flag <- NULL
       }
-      if("FLGEXKEL" %in% names(map_data) && map_data$FLGEXKEL %in% names(data_data)){
-        kel_flag <- as.numeric(tmp_df[,map_data$FLGEXKEL])
-        if(all(is.na(kel_flag))){
-          kel_flag[is.na(kel_flag)] <- 0
-        }
-        if(isTRUE(optimize_kel)){
-          kel_flag <- rep(1, length(tmp_kel_flg))
+      if("FLGEXKEL" %in% names(map_data)) {
+        if(map_data$FLGEXKEL %in% names(data_data)){
+          tmp_kel_flg <- as.numeric(tmp_df[,map_data$FLGEXKEL])
+          kel_flag <- as.numeric(tmp_df[,map_data$FLGEXKEL])
+          if(all(is.na(kel_flag))){
+            kel_flag[is.na(kel_flag)] <- 0
+          }
+          if(isTRUE(optimize_kel)){
+            kel_flag <- rep(1, length(tmp_kel_flg))
+          }
+        } else {
+          kel_flag <- NULL
         }
       } else {
         kel_flag <- NULL
       }
-      if("FLGEXAUC" %in% names(map_data) && map_data$FLGEXAUC %in% names(data_data)){
-        auc_flag <- as.numeric(tmp_df[,map_data$FLGEXAUC])
-        if(all(is.na(auc_flag))){
-          auc_flag[is.na(auc_flag)] <- 0
+      if("FLGEXAUC" %in% names(map_data)) {
+        if(map_data$FLGEXAUC %in% names(data_data)){
+          auc_flag <- as.numeric(tmp_df[,map_data$FLGEXAUC])
+          if(all(is.na(auc_flag))){
+            auc_flag[is.na(auc_flag)] <- 0
+          }
+        } else {
+          auc_flag <- NULL
         }
       } else {
         auc_flag <- NULL
       }
-      if("FLGEMESIS" %in% names(map_data) && map_data$FLGEMESIS %in% names(data_data)){
-        emesis_flag <- as.numeric(tmp_df[,map_data$FLGEMESIS])
-        if(all(is.na(emesis_flag))){
-          emesis_flag[is.na(emesis_flag)] <- 0
+      if("FLGEMESIS" %in% names(map_data)) {
+        if(map_data$FLGEMESIS %in% names(data_data)){
+          emesis_flag <- as.numeric(tmp_df[,map_data$FLGEMESIS])
+          if(all(is.na(emesis_flag))){
+            emesis_flag[is.na(emesis_flag)] <- 0
+          }
+        } else {
+          emesis_flag <- NULL
         }
       } else {
         emesis_flag <- NULL