# R/utils.R In pmxcode: Create Pharmacometric Models

#### Documented in areTruthyget_correlation_tableis_EDBnotTruthy

```#' Pipe operator
#'
#'
#' @name %>%
#' @rdname pipe
#' @keywords internal
#' @export
#' @importFrom magrittr %>%
#' @usage lhs \%>\% rhs
#' @param lhs A value or the magrittr placeholder.
#' @param rhs A function call using the magrittr semantics.
#' @return The result of calling `rhs(lhs)`.
NULL

#' Multi-argument version of isTruthy
#'
#'
#' @name areTruthy
#'
#' @param ... Any object
#'
#' @return TRUE if all objects are "truthy", FALSE if at least one is not.

areTruthy <- function(...){

all(sapply( list(...), shiny::isTruthy ))

}

#' Opposite of areTruthy
#'
#' @name notTruthy
#'
#' @param ... Any object
#'
#' @return TRUE if at least one object is not "truthy", FALSE if all are.

notTruthy <- function(...){

!areTruthy(...)

}

#' Convert of covariance matrix into a 0/1 correlation map table
#' @name get_correlation_table
#' @param x A covariance matrix
#' @param na_zero Logical indicating whether NA should be replaced by 0's
#' @return A matrix of 0 and 1

get_correlation_table <- function(x, na_zero = FALSE){

if ( na_zero ){
x[is.na(x)] <- 0
}
pos <- lower.tri(x, diag = TRUE)
x[pos] <- ifelse( is.na(x[pos]), 0, x[pos] )
x[!is.na(x) & x != 0] <- 1
x

}

#' Determine if a square matrix is of type block, band or error
#'
#' @param x A square matrix
#' @return Either "error", "band", or "block"
#

is_EDB <- function(x){

if ( !inherits(x, "matrix") ){
return("error")
}
if ( nrow(x) != ncol(x) ){
return("error")
}

n <- nrow(x)

if ( n == 1 ){
return("diagonal")
}

x[lower.tri(x)] <- ifelse(
x[lower.tri(x)] > 0,
1,
x[lower.tri(x)]
)

if ( all(x[lower.tri(x)] == 0) ){
return("diagonal")
}

if ( all(x[lower.tri(x)] == 1) ){
return("block")
}

# Check values by diagonal: NA indicates from than one value is present in a diagonal
tmp <- vector("numeric", n-1)

for ( i in 2:n ){
values <- diag(x[i:n, 1:(n-i+1), drop = FALSE])
tmp[i-1] <- ifelse(
length(unique(values)) > 1,
NA,
unique(values)
)
}

# There must be no NA and only decreasing values to be a valid block
if ( any(is.na(tmp)) | any(diff(tmp) > 0) ){
return("error")
} else {
return("block")
}

}
```

## Try the pmxcode package in your browser

Any scripts or data that you put into this service are public.

pmxcode documentation built on June 22, 2024, 9:33 a.m.