|
| 1 | +#' Create compartment data |
| 2 | +#' |
| 3 | +#' @description Creates information on compartments label, size, color, scaling, etc. |
| 4 | +#' |
| 5 | +#' @param prms a numerical vector of parameter values |
| 6 | +#' @param rse a numerical vector of parameter uncertainty |
| 7 | +#' @param advan the nonmem $SUB ADVAN |
| 8 | +#' @param scaling logical if \code{TRUE} compartment size and colors will be scaled |
| 9 | +#' @param scale.fun function to be used for compartment size scaling |
| 10 | +#' @param box.ratio compartment aspect ratio |
| 11 | +#' @param filled logical if \code{TRUE} compartment will be filled |
| 12 | +#' @param font font of the compartment labels |
| 13 | +#' @param node.fontsize font size of the compartment labels |
| 14 | +#' @seealso \code{\link{prm_import}}, \code{\link{modelviz}} |
| 15 | +#' @return A \code{data.frame} of compartments |
| 16 | +#' @export |
| 17 | +make_comp <- function(prms=NA, rse=NA, advan=NULL, |
| 18 | + scaling = TRUE, scale.fun='cubic', |
| 19 | + box.ratio = 3/4, filled = TRUE, |
| 20 | + font = 'Avenir', node.fontsize=12,...){ |
| 21 | + |
| 22 | + check <- function(x, check, uncert=FALSE,...){ |
| 23 | + if(length(setdiff(check,names(x)))>0){ |
| 24 | + message(paste('make_comp: Missing', |
| 25 | + paste(setdiff(check,names(x)),collapse=', '), |
| 26 | + ifelse(uncert,'RSE','value'),'in ADVAN',advan)) |
| 27 | + } |
| 28 | + x[setdiff(check,names(x))] <- NA |
| 29 | + return(x) |
| 30 | + } |
| 31 | + |
| 32 | + if(advan==1){ |
| 33 | + prms <- check(prms,'V',F) |
| 34 | + rse <- check(rse,'V',T) |
| 35 | + node <- DiagrammeR::create_nodes(nodes = paste0('A',1:2), |
| 36 | + label = c('Central','Output'), |
| 37 | + rank = c(1,1), |
| 38 | + prm = c(prms['V'],NA,recursive=TRUE), |
| 39 | + rse = c(rse['V'],NA,recursive=TRUE)) |
| 40 | + } |
| 41 | + |
| 42 | + |
| 43 | + if(advan==2){ |
| 44 | + prms <- check(prms,'V',F) |
| 45 | + rse <- check(rse,'V',T) |
| 46 | + node <- DiagrammeR::create_nodes(nodes = paste0('A',1:3), |
| 47 | + label = c('Depot','Central','Output'), |
| 48 | + rank = c(1,2,2), |
| 49 | + prm = c(NA,prms['V'],NA,recursive=TRUE), |
| 50 | + rse = c(NA,rse['V'],NA,recursive=TRUE)) |
| 51 | + } |
| 52 | + |
| 53 | + |
| 54 | + if(advan==3){ |
| 55 | + prms <- check(prms,c('V1','V2'),F) |
| 56 | + rse <- check(rse,c('V1','V2'),T) |
| 57 | + node <- DiagrammeR::create_nodes(nodes = paste0('A',1:3), |
| 58 | + label = c('Central','Peripheral','Output'), |
| 59 | + rank = c(1,2,1), |
| 60 | + prm = c(prms['V1'],prms['V2'],NA,recursive=TRUE), |
| 61 | + rse = c(rse['V1'],rse['V2'],NA,recursive=TRUE)) |
| 62 | + } |
| 63 | + |
| 64 | + if(advan==4){ |
| 65 | + prms <- check(prms,c('V2','V3'),F) |
| 66 | + rse <- check(rse,c('V2','V3'),T) |
| 67 | + node <- DiagrammeR::create_nodes(nodes = paste0('A',1:4), |
| 68 | + label = c('Depot','Central','Peripheral','Output'), |
| 69 | + rank = c(1,2,3,2), |
| 70 | + prm = c(NA,prms['V2'],prms['V3'],NA,recursive=TRUE), |
| 71 | + rse = c(NA,rse['V2'],rse['V3'],NA,recursive=TRUE)) |
| 72 | + } |
| 73 | + |
| 74 | + if(advan==11){ |
| 75 | + prms <- check(prms,c('V1','V2','V3'),F) |
| 76 | + rse <- check(rse,c('V1','V2','V3'),T) |
| 77 | + node <- DiagrammeR::create_nodes(nodes = paste0('A',1:4), |
| 78 | + label = c('Central','Peripheral 1','Peripheral 2','Output'), |
| 79 | + rank = c(1,2,2,1), |
| 80 | + prm = c(prms['V1'],prms['V2'],prms['V3'],NA,recursive=TRUE), |
| 81 | + rse = c(rse['V1'],rse['V2'],rse['V3'],NA,recursive=TRUE)) |
| 82 | + } |
| 83 | + |
| 84 | + if(advan==12){ |
| 85 | + prms <- check(prms,c('V2','V3','V4'),F) |
| 86 | + rse <- check(rse,c('V2','V3','V4'),T) |
| 87 | + node <- DiagrammeR::create_nodes(nodes = paste0('A',1:5), |
| 88 | + label = c('Depot','Central','Peripheral 1','Peripheral 2','Output'), |
| 89 | + rank = c(1,2,3,3,2), |
| 90 | + prm = c(NA,prms['V2'],prms['V3'],prms['V4'],NA,recursive=TRUE), |
| 91 | + rse = c(NA,rse['V2'],rse['V3'],rse['V4'],NA,recursive=TRUE)) |
| 92 | + } |
| 93 | + |
| 94 | + |
| 95 | + if(advan==20){ |
| 96 | + node <- DiagrammeR::create_nodes(nodes = paste0('A',1:3), |
| 97 | + label = c('Non-RSP','RSP','Dropout'), |
| 98 | + rank = c(1,1,2), |
| 99 | + prm = NA, |
| 100 | + rse = NA, |
| 101 | + shape = 'circle', |
| 102 | + style = 'dashed') |
| 103 | + } |
| 104 | + |
| 105 | + |
| 106 | + # Add formatting to nodes ------------------------------------------------- |
| 107 | + |
| 108 | + if(!'shape'%in%colnames(node)){ |
| 109 | + node$shape <- 'box' |
| 110 | + } |
| 111 | + |
| 112 | + node$scale <- prm_scale(node$prm,FUN=scale.fun) |
| 113 | + |
| 114 | + if(all(is.na(node$rse)) | scaling==FALSE){ |
| 115 | + node$color <- ifelse(!is.na(node$prm),'steelblue4','grey70') |
| 116 | + }else{ |
| 117 | + node$color[is.na(node$rse)] <- 'grey70' |
| 118 | + node$color[node$rse<=0.25] <- 'chartreuse3' |
| 119 | + node$color[node$rse>0.25 & node$rse<0.5] <- 'orange3' |
| 120 | + node$color[node$rse>0.5] <- 'red' |
| 121 | + } |
| 122 | + |
| 123 | + if(filled){ |
| 124 | + node$style <- 'filled' |
| 125 | + }else{ |
| 126 | + node$style <- 'solid' |
| 127 | + node$fontcolor <- node$color |
| 128 | + } |
| 129 | + |
| 130 | + node$style[grepl('^OUT',toupper(node$label))] <- 'invisible' |
| 131 | + node$style[grepl('DEPOT',toupper(node$label))] <- 'dashed' |
| 132 | + node$shape[grepl('DEPOT',toupper(node$label))] <- 'circle' |
| 133 | + node$penwidth <- ifelse(node$style%in%c('filled','invisible'),0,1) |
| 134 | + |
| 135 | + if(scaling){ |
| 136 | + node$width <- ifelse(!is.na(node$scale),node$scale,1) |
| 137 | + }else{ |
| 138 | + node$width <- 1 |
| 139 | + } |
| 140 | + |
| 141 | + node$height <- node$width*ifelse(node$shape=='circle',1,box.ratio) |
| 142 | + node$fontsize <- node.fontsize*node$width |
| 143 | + node$fontname <- font |
| 144 | + |
| 145 | + node$alpha_color <- 80 |
| 146 | + |
| 147 | + return(node) |
| 148 | +} |
0 commit comments