billdenney / pknca

@@ -81,10 +81,10 @@
Loading
81 81
      character(0)
82 82
    }
83 83
  data_no_exclude <-
84 -
    .dat[
84 +
    as.data.frame(.dat[
85 85
      is.na(normalize_exclude(.dat[[exclude]])),,
86 86
      drop=FALSE
87 -
    ]
87 +
    ])
88 88
  data_standard <-
89 89
    standardize_column_names(
90 90
      x=data_no_exclude,

@@ -305,7 +305,3 @@
Loading
305 305
#' @rdname print.PKNCAconc
306 306
#' @export
307 307
summary.PKNCAdose <- summary.PKNCAconc
308 -
309 -
#' @rdname split.PKNCAconc
310 -
#' @export
311 -
split.PKNCAdose <- split.PKNCAconc

@@ -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

@@ -327,74 +327,6 @@
Loading
327 327
328 328
#' @rdname print.PKNCAconc
329 329
#' @export
330 -
summary.PKNCAconc <- function(object, n=0, summarize=TRUE, ...)
330 +
summary.PKNCAconc <- function(object, n=0, summarize=TRUE, ...) {
331 331
  print.PKNCAconc(object, n=n, summarize=summarize)
332 -
333 -
#' Divide into groups
334 -
#' 
335 -
#' \code{split.PKNCAconc} divides data into individual groups defined by
336 -
#' \code{\link{getGroups.PKNCAconc}}.
337 -
#' 
338 -
#' @param x the object to split
339 -
#' @param f the groups to use for splitting the object
340 -
#' @param drop logical indicating if levels that do not occur should be 
341 -
#'   dropped.
342 -
#' @param ... Ignored.
343 -
#' @details If \code{x} is \code{NA} then a list with NA as the only
344 -
#'   element and a "groupid" attribute of an empty data.frame is
345 -
#'   returned.
346 -
#' @return A list of objects with an attribute of groupid consisting of 
347 -
#'   a data.frame with columns for each group.
348 -
#' @export
349 -
split.PKNCAconc <- function(x, f=getGroups(x), drop=TRUE, ...) {
350 -
  if (!drop)
351 -
    stop("drop must be TRUE")
352 -
  if (identical(x, NA)) {
353 -
    ret <- list(NA)
354 -
    groupid <- data.frame(NA)[,c()]
355 -
  } else {
356 -
    ## Do the initial separation and extract the groupid information
357 -
    f_new <-
358 -
      as.character(
359 -
        do.call(
360 -
          paste,
361 -
          append(as.list(f), list(sep="\n"))
362 -
        )
363 -
      )
364 -
    ret <- split(x=x$data, f=f_new, drop=drop, sep="\n")
365 -
    groupid <- unique(f)
366 -
    ## reorder the output to align with the input grouping order
367 -
    ret.idx <-
368 -
      factor(
369 -
        names(ret),
370 -
        levels=do.call(paste, append(as.list(groupid), list(sep="\n"))),
371 -
        ordered=TRUE
372 -
      )
373 -
    ret <- ret[order(ret.idx)]
374 -
    ## Reset the data in each split to a "data" element within a list.
375 -
    ret <-
376 -
      lapply(
377 -
        ret,
378 -
        function(y, newclass) {
379 -
          ret <- list(data=y)
380 -
          class(ret) <- newclass
381 -
          ret
382 -
        },
383 -
        newclass=class(x)
384 -
      )
385 -
    ## Add the other features back into the data
386 -
    for (n in setdiff(names(x), "data")) {
387 -
      ret <-
388 -
        lapply(
389 -
          ret,
390 -
          function(x, name, value) {
391 -
            x[[name]] <- value
392 -
            x
393 -
          },
394 -
          name=n, value=x[[n]]
395 -
        )
396 -
    }
397 -
  }
398 -
  attr(ret, "groupid") <- groupid
399 -
  ret
400 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.
@@ -182,64 +191,6 @@
Loading
182 191
#' @param object The PKNCAdata object to summarize.
183 192
#' @param ... arguments passed on to \code{\link{print.PKNCAdata}}
184 193
#' @export
185 -
summary.PKNCAdata <- function(object, ...)
194 +
summary.PKNCAdata <- function(object, ...) {
186 195
  print.PKNCAdata(object, summarize=TRUE, ...)
187 -
188 -
#' @rdname split.PKNCAconc
189 -
#' @export
190 -
split.PKNCAdata <- function(x, ...) {
191 -
  interval.group.cols <- intersect(names(x$intervals),
192 -
                                   all.vars(parseFormula(x$conc$formula)$groups))
193 -
  if (length(interval.group.cols) > 0) {
194 -
    # If the intervals need to be split across the groups
195 -
    tmp.interval.split <-
196 -
      split.PKNCAconc(list(data=x$intervals),
197 -
                      f=x$intervals[, interval.group.cols, drop=FALSE])
198 -
    tmp.attr <- attributes(tmp.interval.split)
199 -
    tmp.interval.split <- lapply(tmp.interval.split, function(x) x$data)
200 -
    attributes(tmp.interval.split) <- tmp.attr
201 -
    if (identical(NA, x$dose)) {
202 -
      ret <-
203 -
        merge.splitlist(conc=split.PKNCAconc(x$conc),
204 -
                        intervals=tmp.interval.split)
205 -
      ret <- lapply(X=ret,
206 -
                    FUN=function(x) {
207 -
                      x$dose <- NA
208 -
                      x
209 -
                    })
210 -
    } else {
211 -
      ret <-
212 -
        merge.splitlist(conc=split.PKNCAconc(x$conc),
213 -
                        dose=split.PKNCAdose(x$dose),
214 -
                        intervals=tmp.interval.split)
215 -
    }
216 -
  } else {
217 -
    # If the intervals apply to all groups
218 -
    if (identical(NA, x$dose)) {
219 -
      ret <- lapply(X=split.PKNCAconc(x$conc),
220 -
                    FUN=function(x) {
221 -
                      list(conc=x,
222 -
                           dose=NA)
223 -
                    })
224 -
    } else {
225 -
      ret <-
226 -
        merge.splitlist(conc=split.PKNCAconc(x$conc),
227 -
                        dose=split.PKNCAdose(x$dose))
228 -
    }
229 -
    ret <- lapply(X=ret,
230 -
                  FUN=function(x, intervals) {
231 -
                    x$intervals <- intervals
232 -
                    x
233 -
                  }, intervals=x$intervals)
234 -
  }
235 -
  for (n in setdiff(names(x), c("conc", "dose", "intervals"))) {
236 -
    # Add any other attributes to all the splits (like options)
237 -
    ret <-
238 -
      lapply(ret, function(x, name, value) {
239 -
        x[[name]] <- value
240 -
        x
241 -
      },
242 -
      name=n, value=x[[n]])
243 -
  }
244 -
  ret
245 196
}
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