billdenney / pknca

@@ -23,208 +23,146 @@
Loading
23 23
#' @importFrom parallel mclapply
24 24
#' @importFrom stats as.formula update.formula
25 25
#' @importFrom utils capture.output
26 +
#' @importFrom purrr pmap
26 27
pk.nca <- function(data, verbose=FALSE) {
27 28
  if (nrow(data$intervals) == 0) {
28 29
    warning("No intervals given; no calculations done.")
29 30
    results <- data.frame()
30 31
  } else {
31 -
    if (verbose) message("Setting up dosing information")
32 -
    if (identical(NA, data$dose)) {
33 -
      # If no dose information is given, add NULL dose information.
34 -
      message("No dose information provided, calculations requiring dose will return NA.")
35 -
      tmp.dose.data <- unique(getGroups(data$conc))
36 -
      data$dose <-
37 -
        PKNCAdose(
38 -
          data=tmp.dose.data,
39 -
          formula=stats::as.formula(
40 -
            paste0(
41 -
              ".~.|",
42 -
              paste(names(tmp.dose.data), collapse="+")
43 -
            )
44 -
          )
45 -
        )
46 -
    }
47 -
    if (identical(all.vars(parseFormula(data$dose)$lhs), character())) {
48 -
      ## If dose amount is not given, give a false dose column with all 
49 -
      ## NAs to simplify dose handling in subsequent steps.
50 -
      col.dose <- paste0(max(names(data$dose$data)), "X")
51 -
      data$dose$data[,col.dose] <- NA
52 -
      data$dose$formula <-
53 -
        stats::update.formula(data$dose$formula, paste0(col.dose, "~."))
54 -
    }
55 32
    if (verbose) message("Setting up options")
56 33
    ## Merge the options into the default options.
57 34
    tmp.opt <- PKNCA.options()
58 35
    tmp.opt[names(data$options)] <- data$options
59 36
    data$options <- tmp.opt
60 -
    splitdata <- split.PKNCAdata(data)
61 -
    # Calculations will only be performed when an interval is requested
62 -
    if (verbose) message("Checking that intervals have concentration and dose data.")
63 -
    mask_has_interval <-
64 -
      sapply(splitdata,
65 -
             FUN=function(x) {
66 -
               (!is.null(x$intervals)) &&
67 -
                 (nrow(x$intervals) > 0)
68 -
             })
69 -
    mask_has_dose <-
70 -
      sapply(splitdata,
71 -
             FUN=function(x) {
72 -
               !is.null(x$dose)
73 -
             })
74 -
    mask_has_conc <-
75 -
      sapply(splitdata,
76 -
             FUN=function(x) {
77 -
               !is.null(x$conc)
78 -
             })
79 -
    if (any(!mask_has_interval)) {
80 -
      message(sum(!mask_has_interval), " groups have no interval calculations requested.")
81 -
    }
82 -
    if (any(mask_missing_dose <- !mask_has_dose & mask_has_conc & mask_has_interval)) {
83 -
      missing_groups <- list()
84 -
      for (current_idx in which(mask_missing_dose)) {
85 -
        tmp_dose_data <- unique(getGroups(splitdata[[current_idx]]$conc))
86 -
        splitdata[[current_idx]]$dose <-
87 -
          PKNCAdose(
88 -
            data=tmp_dose_data,
89 -
            formula=stats::as.formula(
90 -
              paste0(
91 -
                ".~.|",
92 -
                paste(names(tmp_dose_data), collapse="+"))
93 -
            )
94 -
          )
95 -
        missing_groups <- append(missing_groups, tmp_dose_data)
96 -
      }
97 -
      warning("The following intervals are missing dosing data:\n",
98 -
              paste(
99 -
                capture.output(
100 -
                  print(as.data.frame(dplyr::bind_rows(missing_groups)))),
101 -
                collapse="\n"))
102 -
    }
37 +
    splitdata <- full_join_PKNCAdata(data)
103 38
    ## Calculate the results
104 39
    if (verbose) message("Starting NCA calculations.")
105 -
    tmp.results <- list()
106 -
    tmp.results[mask_has_interval] <-
107 -
      parallel::mclapply(
108 -
        X=splitdata[mask_has_interval],
109 -
        FUN=pk.nca.intervals,
40 +
    tmp_results <-
41 +
      purrr::pmap(
42 +
        .l=list(
43 +
          data_conc=splitdata$data_conc,
44 +
          data_dose=splitdata$data_dose,
45 +
          data_intervals=splitdata$data_intervals
46 +
        ),
47 +
        .f=pk.nca.intervals,
110 48
        options=data$options,
111 49
        verbose=verbose
112 50
      )
113 51
    if (verbose) message("Combining completed results.")
114 -
    ## Put the group parameters with the results
115 -
    for (i in seq_len(length(tmp.results))) {
116 -
      ## If no calculations were performed, the results are NULL.
117 -
      if (!is.null(tmp.results[[i]])) {
118 -
        ## If calculations were performed, the results are non-NULL, add
119 -
        ## the grouping information to the results, if applicable.
120 -
        keep.group.names <- setdiff(names(attr(splitdata, "groupid")),
121 -
                                    names(tmp.results[[i]]))
122 -
        if (length(keep.group.names) > 0) {
123 -
          tmp.results[[i]] <-
124 -
            cbind(attr(splitdata, "groupid")[i,keep.group.names,drop=FALSE],
125 -
                  tmp.results[[i]])
52 +
    ret_prep <-
53 +
      splitdata[
54 +
        ,
55 +
        setdiff(names(splitdata), c("data_conc", "data_dose", "data_intervals")),
56 +
        drop=FALSE
57 +
      ]
58 +
    ret_prep$data_result <- tmp_results
59 +
    # Gather, report, and remove warnings
60 +
    mask_warning <- sapply(X=ret_prep$data_result, inherits, what="warning")
61 +
    ret_warnings <- ret_prep[mask_warning, ]
62 +
    if (nrow(ret_warnings) > 0) {
63 +
      group_names <- setdiff(names(ret_warnings), "data_result")
64 +
      # Tell the user where the warning comes from
65 +
      warning_preamble <-
66 +
        do.call(
67 +
          what=paste,
68 +
          args=
69 +
            append(
70 +
              lapply(
71 +
                X=group_names,
72 +
                FUN=function(x) paste(x, ret_warnings[[x]], sep="=")
73 +
              ),
74 +
              list(sep="; ")
75 +
            )
76 +
        )
77 +
      invisible(lapply(
78 +
        X=seq_along(warning_preamble),
79 +
        FUN=function(idx) {
80 +
          warning_prep <- ret_warnings$data_result[[idx]]
81 +
          warning_prep$message <- paste(warning_preamble[idx], warning_prep$message, sep=": ")
82 +
          warning(warning_prep)
126 83
        }
127 -
      }
84 +
      ))
85 +
    }
86 +
    ret_nowarning <- ret_prep[!mask_warning, ]
87 +
    # Generate the outputs
88 +
    if (nrow(ret_nowarning) == 0) {
89 +
      warning("All results generated warnings or errors; no results generated")
90 +
      results <- data.frame()
91 +
    } else {
92 +
      results <- tidyr::unnest(ret_nowarning, cols="data_result")
93 +
      rownames(results) <- NULL
128 94
    }
129 -
    ## Generate the outputs
130 -
    results <- dplyr::bind_rows(tmp.results)
131 -
    rownames(results) <- NULL
132 95
  }
133 -
  PKNCAresults(result=results,
134 -
               data=data,
135 -
               exclude="exclude")
96 +
  PKNCAresults(
97 +
    result=results,
98 +
    data=data,
99 +
    exclude="exclude"
100 +
  )
136 101
}
137 102
138 103
## Subset data down to just the times of interest and then pass it
139 104
## further to the calculation routines.
140 105
##
141 106
## This is simply a helper for pk.nca
142 -
pk.nca.intervals <- function(conc.dose, intervals, options, verbose=FALSE) {
143 -
  if (is.null(conc.dose$conc)) {
144 -
    ## No data; potentially placebo data (the warning would have
145 -
    ## already been generated from making the PKNCAdata object.
146 -
    return(NULL)
107 +
#' Compute NCA for multiple intervals
108 +
#' 
109 +
#' @param data_conc A data.frame or tibble with standardized column names as
110 +
#'   output from \code{prepare_PKNCAconc()}
111 +
#' @param data_dose A data.frame or tibble with standardized column names as
112 +
#'   output from \code{prepare_PKNCAdose()}
113 +
#' @param data_intervals A data.frame or tibble with standardized column names
114 +
#'   as output from \code{prepare_PKNCAintervals()}
115 +
#' @inheritParams PKNCAdata
116 +
#' @inheritParams pk.nca
117 +
#' @return A data.frame with all NCA results
118 +
#' @importFrom rlang warning_cnd
119 +
pk.nca.intervals <- function(data_conc, data_dose, data_intervals,
120 +
                             options, verbose=FALSE) {
121 +
  if (is.null(data_conc) || (nrow(data_conc) == 0)) {
122 +
    ## No concentration data; potentially placebo data
123 +
    return(rlang::warning_cnd(class="PKNCA_no_conc_data", message="No concentration data"))
124 +
  } else if (is.null(data_intervals) || (nrow(data_intervals) == 0)) {
125 +
    ## No intervals; potentially placebo data
126 +
    return(rlang::warning_cnd(class="PKNCA_no_intervals", message="No intervals for data"))
147 127
  }
148 128
  ret <- data.frame()
149 -
  all.intervals <- conc.dose$intervals
150 -
  pformula.conc <- parseFormula(conc.dose$conc)
151 -
  pformula.dose <- parseFormula(conc.dose$dose)
152 -
  shared.names <- all.vars(pformula.conc$groups)
153 -
  ## Column names to use
154 -
  col.conc <- all.vars(pformula.conc$lhs)
155 -
  col.time <- all.vars(pformula.conc$rhs)
156 -
  col.volume <- conc.dose$conc$columns$volume
157 -
  col.duration.conc <- conc.dose$conc$columns$duration
158 -
  col.include_half.life <- conc.dose$conc$columns$include_half.life
159 -
  col.exclude_half.life <- conc.dose$conc$columns$exclude_half.life
160 -
  col.dose <- all.vars(pformula.dose$lhs)
161 -
  col.time.dose <- all.vars(pformula.dose$rhs)
162 -
  col.duration.dose <- conc.dose$dose$columns$duration
163 -
  col.route <- conc.dose$dose$columns$route
164 -
  # Insert NA doses and dose times if they are not given
165 -
  if (!(col.dose %in% names(conc.dose$dose$data))) {
166 -
    col.dose <- paste0(max(names(conc.dose$dose$data)), "X")
167 -
    conc.dose$dose$data[[col.dose]] <- NA
168 -
  }
169 -
  if (!(col.time.dose %in% names(conc.dose$dose$data))) {
170 -
    col.time.dose <- paste0(max(names(conc.dose$dose$data)), "X")
171 -
    conc.dose$dose$data[[col.time.dose]] <- NA
172 -
  }
173 -
  # Exclude data once at the beginning
174 -
  conc_data_all <-
175 -
    conc.dose$conc$data[
176 -
      # Remove rows to be excluded from all calculations
177 -
      is.na(normalize_exclude(conc.dose$conc$data[[conc.dose$conc$exclude]])),,
178 -
      drop=FALSE]
179 -
  dose_data_all <-
180 -
    conc.dose$dose$data[
181 -
      # Remove rows to be excluded from all calculations
182 -
      is.na(normalize_exclude(conc.dose$dose$data[[conc.dose$dose$exclude]])),,
183 -
      drop=FALSE]
184 -
  for (i in seq_len(nrow(all.intervals))) {
185 -
    ## Subset the data down to the group of current interest, and make 
186 -
    ## the first column of each the dependent variable and the second 
187 -
    ## column the independent variable.
188 -
    conc_data_group <-
189 -
      merge(conc_data_all,
190 -
        all.intervals[
191 -
          i,
192 -
          intersect(shared.names, names(all.intervals)),
193 -
          drop=FALSE])[,
194 -
                       c(col.conc,
195 -
                         col.time,
196 -
                         col.include_half.life,
197 -
                         col.exclude_half.life,
198 -
                         col.volume,
199 -
                         col.duration.conc)]
200 -
    dose_data_group <-
201 -
      merge(dose_data_all,
202 -
        all.intervals[
203 -
          i,
204 -
          intersect(shared.names, names(all.intervals)),
205 -
          drop=FALSE])[,
206 -
                       c(col.dose,
207 -
                         col.time.dose,
208 -
                         col.duration.dose,
209 -
                         col.route)]
129 +
  for (i in seq_len(nrow(data_intervals))) {
210 130
    ## Choose only times between the start and end.
211 -
    mask.keep.conc <- (all.intervals$start[i] <= conc_data_group[[col.time]] &
212 -
                         conc_data_group[[col.time]] <= all.intervals$end[i])
213 -
    conc_data_interval <- conc_data_group[mask.keep.conc,]
214 -
    mask.keep.dose <- (is.na(dose_data_group[,col.time.dose]) |
215 -
                         (all.intervals$start[i] <= dose_data_group[[col.time.dose]] &
216 -
                            dose_data_group[[col.time.dose]] < all.intervals$end[i]))
217 -
    dose_data_interval <- dose_data_group[mask.keep.dose,]
131 +
    mask.keep.conc <-
132 +
      (
133 +
        data_intervals$start[i] <= data_conc$time &
134 +
          data_conc$time <= data_intervals$end[i]
135 +
      )
136 +
    conc_data_interval <- data_conc[mask.keep.conc,]
137 +
    NA_data_dose_ <- data.frame(dose=NA_real_, time=NA_real_, duration=NA_real_, route=NA_real_)
138 +
    if (is.null(data_dose) || identical(data_dose, NA)) {
139 +
      data_dose <- dose_data_interval <- NA_data_dose_
140 +
    } else {
141 +
      mask.keep.dose <-
142 +
        (
143 +
          is.na(data_dose$time) |
144 +
            (data_intervals$start[i] <= data_dose$time &
145 +
               data_dose$time < data_intervals$end[i])
146 +
        )
147 +
      dose_data_interval <- data_dose[mask.keep.dose,]
148 +
    }
218 149
    ## Sort the data in time order
219 -
    conc_data_interval <- conc_data_interval[order(conc_data_interval[[col.time]]),]
220 -
    dose_data_interval <- dose_data_interval[order(dose_data_interval[[col.time.dose]]),]
150 +
    conc_data_interval <- conc_data_interval[order(conc_data_interval$time),]
151 +
    if (nrow(dose_data_interval) > 0) {
152 +
      dose_data_interval <- dose_data_interval[order(dose_data_interval$time),]
153 +
    } else {
154 +
      # When all data are filtered out
155 +
      dose_data_interval <- NA_data_dose_
156 +
    }
221 157
    ## Setup for detailed error reporting in case it's needed
222 158
    error.preamble <-
223 -
      paste("Error with interval",
224 -
            paste(c(shared.names, c("start", "end")),
225 -
                  c(unlist(conc_data_all[1,shared.names]),
226 -
                    unlist(all.intervals[i,c("start", "end")])),
227 -
                  sep="=", collapse=", "))
159 +
      paste(
160 +
        "Error with interval",
161 +
        paste(
162 +
          c("start", "end"),
163 +
          unlist(data_intervals[i, c("start", "end")]),
164 +
          sep="=", collapse=", ")
165 +
      )
228 166
    if (nrow(conc_data_interval) == 0) {
229 167
      warning(paste(error.preamble, "No data for interval", sep=": "))
230 168
    } else {
@@ -232,31 +170,31 @@
Loading
232 170
        {
233 171
          args <- list(
234 172
            # Interval-level data
235 -
            conc=conc_data_interval[[col.conc]],
236 -
            time=conc_data_interval[[col.time]],
237 -
            volume=conc_data_interval[[col.volume]],
238 -
            duration.conc=conc_data_interval[[col.duration.conc]],
239 -
            dose=dose_data_interval[[col.dose]],
240 -
            time.dose=dose_data_interval[[col.time.dose]],
241 -
            duration.dose=dose_data_interval[[col.duration.dose]],
242 -
            route=dose_data_interval[[col.route]],
173 +
            conc=conc_data_interval$conc,
174 +
            time=conc_data_interval$time,
175 +
            volume=conc_data_interval$volume,
176 +
            duration.conc=conc_data_interval$duration,
177 +
            dose=dose_data_interval$dose,
178 +
            time.dose=dose_data_interval$time,
179 +
            duration.dose=dose_data_interval$duration,
180 +
            route=dose_data_interval$route,
243 181
            # Group-level data
244 -
            conc.group=conc_data_group[[col.conc]],
245 -
            time.group=conc_data_group[[col.time]],
246 -
            volume.group=conc_data_group[[col.volume]],
247 -
            duration.conc.group=conc_data_group[[col.duration.conc]],
248 -
            dose.group=dose_data_group[[col.dose]],
249 -
            time.dose.group=dose_data_group[[col.time.dose]],
250 -
            duration.dose.group=dose_data_group[[col.duration.dose]],
251 -
            route.group=dose_data_group[[col.route]],
182 +
            conc.group=data_conc$conc,
183 +
            time.group=data_conc$time,
184 +
            volume.group=data_conc$volume,
185 +
            duration.conc.group=data_conc$duration,
186 +
            dose.group=data_dose$dose,
187 +
            time.dose.group=data_dose$time,
188 +
            duration.dose.group=data_dose$duration,
189 +
            route.group=data_dose$route,
252 190
            # Generic data
253 -
            interval=all.intervals[i, , drop=FALSE],
191 +
            interval=data_intervals[i, , drop=FALSE],
254 192
            options=options)
255 -
          if (!is.null(col.include_half.life)) {
256 -
            args$include_half.life <- conc_data_interval[[col.include_half.life]]
193 +
          if ("include_half.life" %in% names(conc_data_interval)) {
194 +
            args$include_half.life <- conc_data_interval$include_half.life
257 195
          }
258 -
          if (!is.null(col.exclude_half.life)) {
259 -
            args$exclude_half.life <- conc_data_interval[[col.exclude_half.life]]
196 +
          if ("exclude_half.life" %in% names(conc_data_interval)) {
197 +
            args$exclude_half.life <- conc_data_interval$exclude_half.life
260 198
          }
261 199
          ## Try the calculation
262 200
          calculated.interval <- do.call(pk.nca.interval, args)
@@ -266,11 +204,15 @@
Loading
266 204
          stop(e)
267 205
        })
268 206
      ## Add all the new data into the output
269 -
      ret <- rbind(ret,
270 -
                   cbind(all.intervals[i,c("start", "end")],
271 -
                         conc_data_all[1, shared.names, drop=FALSE],
272 -
                         calculated.interval,
273 -
                         row.names=NULL))
207 +
      ret <-
208 +
        rbind(
209 +
          ret,
210 +
          cbind(
211 +
            data_intervals[i, c("start", "end")],
212 +
            calculated.interval,
213 +
            row.names=NULL
214 +
          )
215 +
        )
274 216
    }
275 217
  }
276 218
  ret
@@ -412,7 +354,7 @@
Loading
412 354
          call.args[[arg_formal]] <- route.group
413 355
        } else if (arg_mapped %in% c("start", "end")) {
414 356
          ## Provide the start and end of the interval if they are requested
415 -
          call.args[[arg_formal]] <- interval[1,arg_mapped]
357 +
          call.args[[arg_formal]] <- interval[[arg_mapped]]
416 358
        } else if (arg_mapped == "options") {
417 359
          call.args[[arg_formal]] <- options
418 360
        } else if (any(mask.arg <- ret$PPTESTCD %in% arg_mapped)) {

@@ -248,6 +248,12 @@
Loading
248 248
  getGroups.PKNCAconc(...)
249 249
}
250 250
251 +
#' @describeIn group_vars.PKNCAconc Get group_vars for a PKNCAdose object
252 +
#' @exportS3Method dplyr::group_vars
253 +
group_vars.PKNCAdose <- function(x) {
254 +
  group_vars.PKNCAconc(x)
255 +
}
256 +
251 257
#' @rdname getData.PKNCAconc
252 258
#' @export
253 259
#' @importFrom nlme getData
@@ -299,7 +305,3 @@
Loading
299 305
#' @rdname print.PKNCAconc
300 306
#' @export
301 307
summary.PKNCAdose <- summary.PKNCAconc
302 -
303 -
#' @rdname split.PKNCAconc
304 -
#' @export
305 -
split.PKNCAdose <- split.PKNCAconc

@@ -228,6 +228,15 @@
Loading
228 228
  data[, grpnames, drop=FALSE]
229 229
}
230 230
231 +
#' Get grouping variables for a PKNCA object
232 +
#'
233 +
#' @param x The PKNCA object
234 +
#' @return A character vector (possibly empty) of the grouping variables
235 +
#' @exportS3Method dplyr::group_vars
236 +
group_vars.PKNCAconc <- function(x) {
237 +
  all.vars(parseFormula(as.formula(x))$groups)
238 +
}
239 +
231 240
#' Extract all the original data from a PKNCAconc or PKNCAdose object
232 241
#' @param object R object to extract the data from.
233 242
#' @export
@@ -318,74 +327,6 @@
Loading
318 327
319 328
#' @rdname print.PKNCAconc
320 329
#' @export
321 -
summary.PKNCAconc <- function(object, n=0, summarize=TRUE, ...)
330 +
summary.PKNCAconc <- function(object, n=0, summarize=TRUE, ...) {
322 331
  print.PKNCAconc(object, n=n, summarize=summarize)
323 -
324 -
#' Divide into groups
325 -
#' 
326 -
#' \code{split.PKNCAconc} divides data into individual groups defined by
327 -
#' \code{\link{getGroups.PKNCAconc}}.
328 -
#' 
329 -
#' @param x the object to split
330 -
#' @param f the groups to use for splitting the object
331 -
#' @param drop logical indicating if levels that do not occur should be 
332 -
#'   dropped.
333 -
#' @param ... Ignored.
334 -
#' @details If \code{x} is \code{NA} then a list with NA as the only
335 -
#'   element and a "groupid" attribute of an empty data.frame is
336 -
#'   returned.
337 -
#' @return A list of objects with an attribute of groupid consisting of 
338 -
#'   a data.frame with columns for each group.
339 -
#' @export
340 -
split.PKNCAconc <- function(x, f=getGroups(x), drop=TRUE, ...) {
341 -
  if (!drop)
342 -
    stop("drop must be TRUE")
343 -
  if (identical(x, NA)) {
344 -
    ret <- list(NA)
345 -
    groupid <- data.frame(NA)[,c()]
346 -
  } else {
347 -
    ## Do the initial separation and extract the groupid information
348 -
    f_new <-
349 -
      as.character(
350 -
        do.call(
351 -
          paste,
352 -
          append(as.list(f), list(sep="\n"))
353 -
        )
354 -
      )
355 -
    ret <- split(x=x$data, f=f_new, drop=drop, sep="\n")
356 -
    groupid <- unique(f)
357 -
    ## reorder the output to align with the input grouping order
358 -
    ret.idx <-
359 -
      factor(
360 -
        names(ret),
361 -
        levels=do.call(paste, append(as.list(groupid), list(sep="\n"))),
362 -
        ordered=TRUE
363 -
      )
364 -
    ret <- ret[order(ret.idx)]
365 -
    ## Reset the data in each split to a "data" element within a list.
366 -
    ret <-
367 -
      lapply(
368 -
        ret,
369 -
        function(y, newclass) {
370 -
          ret <- list(data=y)
371 -
          class(ret) <- newclass
372 -
          ret
373 -
        },
374 -
        newclass=class(x)
375 -
      )
376 -
    ## Add the other features back into the data
377 -
    for (n in setdiff(names(x), "data")) {
378 -
      ret <-
379 -
        lapply(
380 -
          ret,
381 -
          function(x, name, value) {
382 -
            x[[name]] <- value
383 -
            x
384 -
          },
385 -
          name=n, value=x[[n]]
386 -
        )
387 -
    }
388 -
  }
389 -
  attr(ret, "groupid") <- groupid
390 -
  ret
391 332
}

@@ -97,45 +97,54 @@
Loading
97 97
  } else if (missing(intervals)) {
98 98
    ## Generate the intervals for each grouping of concentration and
99 99
    ## dosing.
100 -
    tmp.conc.dose <-
101 -
      merge.splitlist(
102 -
        conc=split(ret$conc),
103 -
        dose=split(ret$dose)
104 -
      )
105 -
    groupid <- attributes(tmp.conc.dose)$groupid
106 -
    rownames(groupid) <- NULL
107 -
    intervals <- data.frame()
108 -
    indep.var.conc <- all.vars(parseFormula(ret$conc)$rhs)
109 -
    indep.var.dose <- all.vars(parseFormula(ret$dose)$rhs)
110 -
    if (identical(indep.var.dose, ".")) {
100 +
    if (identical(all.vars(parseFormula(ret$dose)$rhs), ".")) {
111 101
      stop("Dose times were not given, so intervals must be manually specified.")
112 102
    }
113 -
    for (i in seq_len(nrow(groupid))) {
114 -
      tmp.group <- groupid[i,,drop=FALSE]
115 -
      if (!is.null(tmp.conc.dose[[i]]$conc)) {
116 -
        rownames(tmp.group) <- NULL
103 +
    n_conc_dose <-
104 +
      full_join_PKNCAconc_PKNCAdose(
105 +
        conc=ret$conc,
106 +
        dose=ret$dose
107 +
      )
108 +
    n_conc_dose$data_intervals <- rep(list(NULL), nrow(n_conc_dose))
109 +
    for (idx in seq_len(nrow(n_conc_dose))) {
110 +
      current_conc <- n_conc_dose$data_conc[[idx]]
111 +
      current_dose <- n_conc_dose$data_dose[[idx]]
112 +
      current_group <-
113 +
        n_conc_dose[
114 +
          idx,
115 +
          setdiff(names(n_conc_dose), c("data_conc", "data_dose")),
116 +
          drop=FALSE
117 +
        ]
118 +
      warning_prefix <-
119 +
        if (ncol(current_group) > 0) {
120 +
          paste0(
121 +
            paste(names(current_group), unlist(lapply(current_group, as.character)), sep="=", collapse="; "),
122 +
            ": "
123 +
          )
124 +
        } else {
125 +
          ""
126 +
        }
127 +
      if (!is.null(current_conc)) {
117 128
        generated_intervals <-
118 129
          choose.auc.intervals(
119 -
            tmp.conc.dose[[i]]$conc$data[,indep.var.conc],
120 -
            tmp.conc.dose[[i]]$dose$data[,indep.var.dose],
130 +
            current_conc$time,
131 +
            current_dose$time,
121 132
            options=options
122 133
          )
123 -
        if (nrow(generated_intervals)) {
124 -
          new.intervals <- cbind(tmp.group, generated_intervals)
125 -
          intervals <- rbind(intervals, new.intervals)
134 +
        if (nrow(generated_intervals) > 0) {
135 +
          n_conc_dose$data_intervals[[idx]] <- generated_intervals
126 136
        } else {
127 -
          warning("No intervals generated likely due to limited concentration data for ",
128 -
                  paste(names(tmp.group),
129 -
                        unlist(lapply(tmp.group, as.character)),
130 -
                        sep="=", collapse=", "))
137 +
          warning(warning_prefix, "No intervals generated likely due to limited concentration data")
131 138
        }
132 139
      } else {
133 -
        warning("No intervals generated due to no concentration data for ",
134 -
                paste(names(tmp.group),
135 -
                      unlist(lapply(tmp.group, as.character)),
136 -
                      sep="=", collapse=", "))
140 +
        warning(warning_prefix, "No intervals generated due to no concentration data")
137 141
      }
138 142
    }
143 +
    intervals <-
144 +
      tidyr::unnest(
145 +
        n_conc_dose[, setdiff(names(n_conc_dose), c("data_conc", "data_dose")), drop=FALSE],
146 +
        cols="data_intervals"
147 +
      )
139 148
  }
140 149
  ret$intervals <- check.interval.specification(intervals)
141 150
  ## Assign the class and give it all back to the user.
@@ -168,76 +177,20 @@
Loading
168 177
#' Extract all the original data from a PKNCAconc or PKNCAdose object
169 178
#' @param object R object to extract the data from.
170 179
#' @export
171 -
getData.PKNCAdata <- function(object)
180 +
getData.PKNCAdata <- function(object) {
172 181
  object$data
182 +
}
173 183
174 184
#' @rdname getDataName
175 -
getDataName.PKNCAdata <- function(object)
185 +
getDataName.PKNCAdata <- function(object) {
176 186
  "data"
187 +
}
177 188
178 189
#' Summarize a PKNCAdata object showing important details about the
179 190
#' concentration, dosing, and interval information.
180 191
#' @param object The PKNCAdata object to summarize.
181 192
#' @param ... arguments passed on to \code{\link{print.PKNCAdata}}
182 193
#' @export
183 -
summary.PKNCAdata <- function(object, ...)
194 +
summary.PKNCAdata <- function(object, ...) {
184 195
  print.PKNCAdata(object, summarize=TRUE, ...)
185 -
186 -
#' @rdname split.PKNCAconc
187 -
#' @export
188 -
split.PKNCAdata <- function(x, ...) {
189 -
  interval.group.cols <- intersect(names(x$intervals),
190 -
                                   all.vars(parseFormula(x$conc$formula)$groups))
191 -
  if (length(interval.group.cols) > 0) {
192 -
    # If the intervals need to be split across the groups
193 -
    tmp.interval.split <-
194 -
      split.PKNCAconc(list(data=x$intervals),
195 -
                      f=x$intervals[, interval.group.cols, drop=FALSE])
196 -
    tmp.attr <- attributes(tmp.interval.split)
197 -
    tmp.interval.split <- lapply(tmp.interval.split, function(x) x$data)
198 -
    attributes(tmp.interval.split) <- tmp.attr
199 -
    if (identical(NA, x$dose)) {
200 -
      ret <-
201 -
        merge.splitlist(conc=split.PKNCAconc(x$conc),
202 -
                        intervals=tmp.interval.split)
203 -
      ret <- lapply(X=ret,
204 -
                    FUN=function(x) {
205 -
                      x$dose <- NA
206 -
                      x
207 -
                    })
208 -
    } else {
209 -
      ret <-
210 -
        merge.splitlist(conc=split.PKNCAconc(x$conc),
211 -
                        dose=split.PKNCAdose(x$dose),
212 -
                        intervals=tmp.interval.split)
213 -
    }
214 -
  } else {
215 -
    # If the intervals apply to all groups
216 -
    if (identical(NA, x$dose)) {
217 -
      ret <- lapply(X=split.PKNCAconc(x$conc),
218 -
                    FUN=function(x) {
219 -
                      list(conc=x,
220 -
                           dose=NA)
221 -
                    })
222 -
    } else {
223 -
      ret <-
224 -
        merge.splitlist(conc=split.PKNCAconc(x$conc),
225 -
                        dose=split.PKNCAdose(x$dose))
226 -
    }
227 -
    ret <- lapply(X=ret,
228 -
                  FUN=function(x, intervals) {
229 -
                    x$intervals <- intervals
230 -
                    x
231 -
                  }, intervals=x$intervals)
232 -
  }
233 -
  for (n in setdiff(names(x), c("conc", "dose", "intervals"))) {
234 -
    # Add any other attributes to all the splits (like options)
235 -
    ret <-
236 -
      lapply(ret, function(x, name, value) {
237 -
        x[[name]] <- value
238 -
        x
239 -
      },
240 -
      name=n, value=x[[n]])
241 -
  }
242 -
  ret
243 196
}

@@ -0,0 +1,247 @@
Loading
1 +
#' Combine PKNCAconc and PKNCAdose objects
2 +
#' 
3 +
#' The function is inspired by \code{dplyr::full_join}, but it has different
4 +
#' semantics.
5 +
#' 
6 +
#' @param conc a PKNCAconc object
7 +
#' @param dose a PKNCAdose object or \code{NA}
8 +
#' @return A tibble with columns for the groups, "data_conc" (the concentration
9 +
#'   data), and "data_dose" (the dosing data).  If \code{is.na(dose)},
10 +
#'   "data_dose" will be \code{NA}.
11 +
#' @family Combine PKNCA objects
12 +
#' @keywords Internal
13 +
#' @noRd
14 +
#' @importFrom dplyr full_join
15 +
#' @importFrom tibble tibble
16 +
#' @importFrom tidyr crossing
17 +
full_join_PKNCAconc_PKNCAdose <- function(conc, dose) {
18 +
  stopifnot(inherits(x=conc, what="PKNCAconc"))
19 +
  if (identical(dose, NA)) {
20 +
    message("No dose information provided, calculations requiring dose will return NA.")
21 +
    n_dose <- tibble::tibble(data_dose=list(NA))
22 +
  } else {
23 +
    stopifnot(inherits(x=dose, what="PKNCAdose"))
24 +
    n_dose <- prepare_PKNCAdose(dose)
25 +
  }
26 +
  n_conc <- prepare_PKNCAconc(conc)
27 +
  shared_groups <- intersect(names(n_conc), names(n_dose))
28 +
  if (length(shared_groups) > 0) {
29 +
    dplyr::full_join(n_conc, n_dose, by=shared_groups)
30 +
  } else {
31 +
    tidyr::crossing(n_conc, n_dose)
32 +
  }
33 +
}
34 +
35 +
#' Convert a PKNCAdata object into a data.frame for analysis
36 +
#' 
37 +
#' The function is inspired by \code{dplyr::full_join}, but it has different
38 +
#' semantics.
39 +
#' 
40 +
#' @param x The PKNCAdata object
41 +
#' @return A tibble with columns the grouping variables, "data_conc" for
42 +
#'   concentration data, "data_dose" for dosing data, and "data_intervals" for
43 +
#'   intervals data.
44 +
#' @family Combine PKNCA objects
45 +
#' @keywords Internal
46 +
#' @noRd
47 +
#' @importFrom dplyr full_join
48 +
#' @importFrom tidyr crossing
49 +
full_join_PKNCAdata <- function(x) {
50 +
  conc_dose <- full_join_PKNCAconc_PKNCAdose(x$conc, x$dose)
51 +
  n_i <-
52 +
    prepare_PKNCAintervals(
53 +
      .dat=x$intervals,
54 +
      vars=setdiff(names(conc_dose), c("data_conc", "data_dose", "data_intervals"))
55 +
    )
56 +
  shared_groups <- intersect(names(conc_dose), names(n_i))
57 +
  if (length(shared_groups) > 0) {
58 +
    ret <- dplyr::full_join(conc_dose, n_i, by=shared_groups)
59 +
  } else {
60 +
    ret <- tidyr::crossing(conc_dose, n_i)
61 +
  }
62 +
  ret
63 +
}
64 +
65 +
#' Prepare a PKNCA object and drop unnecessary columns
66 +
#' 
67 +
#' @param .dat The PKNCA object to prepare as a nested tibble
68 +
#' @param ...,.names_sep,.key Ignored
69 +
#' @return A nested tibble with a column named "data_conc" containing the concentration data and a column 
70 +
#' @family Combine PKNCA objects
71 +
#' @keywords Internal
72 +
#' @noRd
73 +
#' @importFrom dplyr grouped_df
74 +
#' @importFrom tidyr nest
75 +
prepare_PKNCA_general <- function(.dat, cols, exclude, group_cols, data_name, insert_if_missing=list()) {
76 +
  check_reserved_column_names(.dat)
77 +
  intermediate_group_cols <-
78 +
    if (length(group_cols) > 0) {
79 +
      paste0("group", seq_along(group_cols))
80 +
    } else {
81 +
      character(0)
82 +
    }
83 +
  data_no_exclude <-
84 +
    as.data.frame(.dat[
85 +
      is.na(normalize_exclude(.dat[[exclude]])),,
86 +
      drop=FALSE
87 +
    ])
88 +
  data_standard <-
89 +
    standardize_column_names(
90 +
      x=data_no_exclude,
91 +
      cols=cols,
92 +
      group_cols=group_cols,
93 +
      insert_if_missing=insert_if_missing
94 +
    )
95 +
  # data_conc is used since it is reserved, and it will be replaced on the next
96 +
  # line.
97 +
  as_nest <- tidyr::nest(data_standard, data_conc=!intermediate_group_cols)
98 +
  names(as_nest)[names(as_nest) %in% "data_conc"] <- data_name
99 +
  ret <- restore_group_col_names(as_nest, group_cols=group_cols)
100 +
  ret
101 +
}
102 +
103 +
prepare_PKNCAconc <- function(.dat) {
104 +
  # Remove rows to be excluded from all calculations
105 +
  # Drop unnecessary column names
106 +
  pformula_conc <- parseFormula(.dat)
107 +
  needed_cols <-
108 +
    list(
109 +
      conc=all.vars(pformula_conc$lhs),
110 +
      time=all.vars(pformula_conc$rhs),
111 +
      volume=.dat$columns$volume,
112 +
      duration=.dat$columns$duration,
113 +
      include_half.life=.dat$columns$include_half.life,
114 +
      exclude_half.life=.dat$columns$exclude_half.life
115 +
    )
116 +
  ret <-
117 +
    prepare_PKNCA_general(
118 +
      .dat=.dat$data,
119 +
      exclude=.dat$exclude,
120 +
      cols=needed_cols,
121 +
      data_name="data_conc",
122 +
      group_cols=all.vars(pformula_conc$groups)
123 +
    )
124 +
  ret
125 +
}
126 +
127 +
#' @describeIn prepare_PKNCAconc Nest a PKNCAdose object
128 +
#' @noRd
129 +
#' @family Combine PKNCA objects
130 +
#' @keywords Internal
131 +
#' @importFrom dplyr grouped_df
132 +
#' @importFrom tidyr nest
133 +
prepare_PKNCAdose <- function(.dat) {
134 +
  pformula_dose <- parseFormula(.dat)
135 +
  dose_col <- all.vars(pformula_dose$lhs)
136 +
  time_col <- all.vars(pformula_dose$rhs)
137 +
  if (length(dose_col) == 0 || dose_col %in% ".") dose_col <- NULL
138 +
  if (time_col %in% ".") time_col <- NULL
139 +
  needed_cols <-
140 +
    list(
141 +
      dose=dose_col,
142 +
      time=time_col,
143 +
      duration=.dat$columns$duration,
144 +
      route=.dat$columns$route
145 +
    )
146 +
  ret <-
147 +
    prepare_PKNCA_general(
148 +
      .dat=.dat$data,
149 +
      exclude=.dat$exclude,
150 +
      cols=needed_cols,
151 +
      data_name="data_dose",
152 +
      group_cols=all.vars(pformula_dose$groups),
153 +
      insert_if_missing=list(dose=NA, time=NA)
154 +
    )
155 +
  ret
156 +
}
157 +
158 +
#' @describeIn prepare_PKNCAconc Nest a PKNCAdose object
159 +
#' @noRd
160 +
#' @family Combine PKNCA objects
161 +
#' @keywords Internal
162 +
#' @importFrom dplyr grouped_df
163 +
#' @importFrom tidyr nest
164 +
#' @importFrom tibble as_tibble tibble
165 +
prepare_PKNCAintervals <- function(.dat, vars=character(0)) {
166 +
  check_reserved_column_names(.dat)
167 +
  .dat <- tibble::as_tibble(.dat)
168 +
  vars <- intersect(vars, names(.dat))
169 +
  if (length(vars) == 0) {
170 +
    as_nest <- tibble::tibble(data_intervals=list(.dat))
171 +
  } else {
172 +
    as_nest <- tidyr::nest(.dat, data_intervals=!vars)
173 +
  }
174 +
  as_nest
175 +
}
176 +
177 +
#' Confirm that PKNCA reserved column names are not in a data.frame
178 +
#'
179 +
#' @param x A data.frame or similar object
180 +
#' @return NULL (generate an error if a reserved name is present)
181 +
#' @keywords Internal
182 +
#' @noRd
183 +
check_reserved_column_names <- function(x) {
184 +
  reserved_names <- c("data_conc", "data_dose", "data_intervals", "data_results")
185 +
  overlap <- intersect(reserved_names, names(x))
186 +
  if (length(overlap) > 0) {
187 +
    msg <-
188 +
      paste(
189 +
        ngettext(length(overlap), msg1="The column", msg2="The columns"),
190 +
        paste0("'", overlap, "'", collapse=", "),
191 +
        ngettext(length(overlap), msg1="is", msg2="are"),
192 +
        "reserved for internal use in PKNCA.  Change the",
193 +
        ngettext(length(overlap), msg1="name", msg2="names"),
194 +
        "and retry."
195 +
      )
196 +
    stop(msg)
197 +
  }
198 +
}
199 +
200 +
#' Standardize column names and drop unnecessary columns from a data.frame or tibble
201 +
#' 
202 +
#' @param x The data.frame or tibble
203 +
#' @param cols A named list where the names are the standardized column names and the values are the original column names
204 +
#' @return A data.frame or tibble with columns cleaned of unlisted columns and with names set to the expected names.
205 +
#' @noRd
206 +
#' @keywords Internal
207 +
standardize_column_names <- function(x, cols, group_cols=NULL, insert_if_missing=list()) {
208 +
  stopifnot("cols must be a list"=is.list(cols))
209 +
  stopifnot("cols must be named"=!is.null(names(cols)))
210 +
  stopifnot("all cols must be named"=!any(names(cols) %in% ""))
211 +
  stopifnot("all original cols names must be names of x"=all(unlist(cols) %in% names(x)))
212 +
  stopifnot("group_cols must be NULL or a character vector"=is.null(group_cols) || is.character(group_cols))
213 +
  if (!is.null(group_cols)) {
214 +
    stopifnot("group_cols must not overlap with other column names"=!any(group_cols %in% unlist(cols)))
215 +
    stopifnot("group_cols must not overlap with standardized column names"=!any(group_cols %in% names(cols)))
216 +
    new_group_cols <- paste0("group", seq_along(group_cols))
217 +
  } else {
218 +
    new_group_cols <- NULL
219 +
  }
220 +
  cols_clean <- cols[!sapply(X=cols, FUN=is.null)]
221 +
  ret <-
222 +
    setNames(
223 +
      # Keep only columns of interest
224 +
      x[, c(group_cols, unlist(cols_clean)), drop=FALSE],
225 +
      nm=c(new_group_cols, names(cols_clean))
226 +
    )
227 +
  for (current_nm in names(insert_if_missing)) {
228 +
    if (!(current_nm %in% names(ret))) {
229 +
      ret[[current_nm]] <- insert_if_missing[[current_nm]]
230 +
    }
231 +
  }
232 +
  ret
233 +
}
234 +
235 +
restore_group_col_names <- function(x, group_cols=NULL) {
236 +
  if (is.null(group_cols)) {
237 +
    return(x)
238 +
  }
239 +
  new_group_cols <- paste0("group", seq_along(group_cols))
240 +
  stopifnot("missing intermediate group_cols names"=all(new_group_cols %in% names(x)))
241 +
  stopifnot(
242 +
    "Intermediate group_cols are out of order"=
243 +
      all(names(x)[names(x) %in% new_group_cols] == new_group_cols)
244 +
  )
245 +
  names(x)[names(x) %in% new_group_cols] <- group_cols
246 +
  x
247 +
}

@@ -57,22 +57,21 @@
Loading
57 57
superposition.PKNCAconc <- function(conc, ...) {
58 58
  ## Split the data by grouping and extract just the concentration and
59 59
  ## time columns
60 -
  tmp.data <- split.PKNCAconc(conc)
61 -
  groupinfo <- attr(tmp.data, 'groupid')
62 -
  tmp.results <-
60 +
  nested_data <- prepare_PKNCAconc(conc)
61 +
  tmp_results <-
63 62
    parallel::mclapply(
64 -
      X=seq_along(tmp.data),
65 -
      FUN=function(x, conc.col, time.col, ...) {
66 -
        cbind(groupinfo[x,,drop=FALSE],
67 -
              superposition.numeric(tmp.data[[x]]$data[[conc.col]],
68 -
                                    tmp.data[[x]]$data[[time.col]],
69 -
                                    ...),
70 -
              row.names=NULL)
71 -
      },
72 -
      conc.col=as.character(parseFormula(conc)$lhs),
73 -
      time.col=as.character(parseFormula(conc)$rhs),
74 -
      ...)
75 -
  dplyr::bind_rows(tmp.results)
63 +
      X=seq_len(nrow(nested_data)),
64 +
      FUN=function(idx) {
65 +
        superposition.numeric(
66 +
          conc=nested_data$data_conc[[idx]]$conc,
67 +
          time=nested_data$data_conc[[idx]]$time,
68 +
          ...
69 +
        )
70 +
      }
71 +
    )
72 +
  # Replace the concentration data with the new results
73 +
  nested_data$data_conc <- tmp_results
74 +
  tidyr::unnest(nested_data, cols="data_conc")
76 75
}
77 76
78 77
#' @rdname superposition

@@ -149,18 +149,18 @@
Loading
149 149
      exclude <-
150 150
        setdiff(c("exclude", paste0("exclude.", max(names(object[[dataname]])))),
151 151
                names(object[[dataname]]))[1]
152 -
      object[[dataname]][,exclude] <- rep(NA_character_, nrow(object[[dataname]]))
152 +
      object[[dataname]][[exclude]] <- rep(NA_character_, nrow(object[[dataname]]))
153 153
    } else if (nrow(object[[dataname]]) == 0) {
154 -
      object[[dataname]][,exclude] <- rep(NA_character_, nrow(object[[dataname]]))
154 +
      object[[dataname]][[exclude]] <- rep(NA_character_, nrow(object[[dataname]]))
155 155
    } else if (!(exclude %in% names(object[[dataname]]))) {
156 156
      stop("exclude, if given, must be a column name in the input data.")
157 157
    } else {
158 -
      if (is.factor(object[[dataname]][,exclude])) {
159 -
        object[[dataname]][,exclude] <- as.character(object[[dataname]][,exclude])
160 -
      } else if (is.logical(object[[dataname]][,exclude]) &
161 -
                 all(is.na(object[[dataname]][,exclude]))) {
162 -
        object[[dataname]][,exclude] <- rep(NA_character_, nrow(object[[dataname]]))
163 -
      } else if (!is.character(object[[dataname]][,exclude])) {
158 +
      if (is.factor(object[[dataname]][[exclude]])) {
159 +
        object[[dataname]][[exclude]] <- as.character(object[[dataname]][[exclude]])
160 +
      } else if (is.logical(object[[dataname]][[exclude]]) &
161 +
                 all(is.na(object[[dataname]][[exclude]]))) {
162 +
        object[[dataname]][[exclude]] <- rep(NA_character_, nrow(object[[dataname]]))
163 +
      } else if (!is.character(object[[dataname]][[exclude]])) {
164 164
        stop("exclude column must be character vector or something convertable to character without loss of information.")
165 165
      }
166 166
    }
Files Coverage
R 96.16%
Project Totals (33 files) 96.16%
1
comment: false
2

3
coverage:
4
  status:
5
    project:
6
      default:
7
        target: auto
8
        threshold: 1%
9
        informational: true
10
    patch:
11
      default:
12
        target: auto
13
        threshold: 1%
14
        informational: true
Sunburst
The inner-most circle is the entire project, moving away from the center are folders then, finally, a single file. The size and color of each slice is representing the number of statements and the coverage, respectively.
Icicle
The top section represents the entire project. Proceeding with folders and finally individual files. The size and color of each slice is representing the number of statements and the coverage, respectively.
Grid
Each block represents a single file in the project. The size and color of each block is represented by the number of statements and the coverage, respectively.
Loading