P281424
/
AMR
mirror of https://github.com/msberends/AMR.git
1
0
Fork 0
Code Releases Activity

speed improvements

This commit is contained in:
dr. M.S. (Matthijs) Berends 2018-07-17 10:32:26 +02:00
parent 715a7630ca
commit a5a4354651
12 changed files with 52 additions and 213 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
DESCRIPTION
View File

@ -1,6 +1,6 @@
Package: AMR
Version: 0.2.0.9012
Date: 2018-07-16
Date: 2018-07-17
Title: Antimicrobial Resistance Analysis
Authors@R: c(
person(

2
NAMESPACE
View File

@ -94,7 +94,6 @@ exportMethods(skewness.matrix)
exportMethods(summary.mic)
exportMethods(summary.rsi)
importFrom(Rcpp,evalCpp)
importFrom(broom,tidy)
importFrom(clipr,read_clip_tbl)
importFrom(clipr,write_clip)
importFrom(curl,nslookup)
@ -141,7 +140,6 @@ importFrom(rvest,html_table)
importFrom(stats,complete.cases)
importFrom(stats,fivenum)
importFrom(stats,mad)
importFrom(stats,na.omit)
importFrom(stats,pchisq)
importFrom(stats,sd)
importFrom(tibble,tibble)

2
NEWS.md
View File

@ -19,7 +19,7 @@ ratio(c(772, 1611, 737), ratio = "1:2:1")
* Function `top_freq` function to return the top/below *n* items as vector
* Header of frequency tables now also show Mean Absolute Deviaton (MAD) and Interquartile Range (IQR)
* Possibility to globally set the default for the amount of items to print, with `options(max.print.freq = n)` where *n* is your preset value
* Functions `clipboard_import` and `clipboard_export` as helper functions to quickly copy and paste from/to software like Excel and SPSS
* Functions `clipboard_import` and `clipboard_export` as helper functions to quickly copy and paste from/to software like Excel and SPSS. These functions use the `clipr` package, but are a little altered to also support headless Linux servers (so you can use it in RStudio Server).
#### Changed
* Pretty printing for tibbles removed as it is not really the scope of this package

4
R/RcppExports.R
View File

@ -9,7 +9,3 @@ rsi_calc_R <- function(x, include_I) {
.Call(`_AMR_rsi_calc_R`, x, include_I)
}
rsi_calc_total <- function(x) {
.Call(`_AMR_rsi_calc_total`, x)
}

12
R/clipboard.R
View File

@ -72,7 +72,12 @@ clipboard_import <- function(sep = '\t',
encoding = "UTF-8",
info = TRUE) {
# this will fail when clipr is not available
if (!clipr::clipr_available() & Sys.info()['sysname'] == "Linux") {
# try to support on X11, by setting the R variable DISPLAY
Sys.setenv(DISPLAY = "localhost:10.0")
}
# this will fail when clipr is (still) not available
import_tbl <- clipr::read_clip_tbl(file = file,
sep = sep,
header = header,
@ -134,6 +139,11 @@ clipboard_export <- function(x,
header = TRUE,
info = TRUE) {
if (!clipr::clipr_available() & Sys.info()['sysname'] == "Linux") {
# try to support on X11, by setting the R variable DISPLAY
Sys.setenv(DISPLAY = "localhost:10.0")
}
clipr::write_clip(content = x,
na = na,
sep = sep,

38
R/resistance.R
View File

@ -136,10 +136,11 @@ resistance <- function(ab,
if (!is.rsi(ab)) {
x <- as.rsi(ab)
warning("Increase speed by transforming to class `rsi` on beforehand: df %>% mutate_at(vars(col10:col20), as.rsi)")
} else {
x <- ab
}
total <- .Call(`_AMR_rsi_calc_total`, x)
total <- length(x) - sum(is.na(x)) # faster than C++
if (total < minimum) {
return(NA)
}
@ -173,8 +174,10 @@ susceptibility <- function(ab1,
stop('`as_percent` must be logical', call. = FALSE)
}
print_warning <- FALSE
if (!is.rsi(ab1)) {
ab1 <- as.rsi(ab1)
print_warning <- TRUE
}
if (!is.null(ab2)) {
if (NCOL(ab2) > 1) {
@ -182,6 +185,7 @@ susceptibility <- function(ab1,
}
if (!is.rsi(ab2)) {
ab2 <- as.rsi(ab2)
print_warning <- TRUE
}
x <- apply(X = data.frame(ab1 = as.integer(ab1),
ab2 = as.integer(ab2)),
@ -190,12 +194,16 @@ susceptibility <- function(ab1,
} else {
x <- ab1
}
total <- .Call(`_AMR_rsi_calc_total`, x)
total <- length(x) - sum(is.na(x))
if (total < minimum) {
return(NA)
}
found <- .Call(`_AMR_rsi_calc_S`, x, include_I)
if (print_warning == TRUE) {
warning("Increase speed by transforming to class `rsi` on beforehand: df %>% mutate_at(vars(col10:col20), as.rsi)")
}
if (as_percent == TRUE) {
percent(found / total, force_zero = TRUE)
} else {
@ -219,14 +227,10 @@ n_rsi <- function(ab1, ab2 = NULL) {
if (!is.rsi(ab2)) {
ab2 <- as.rsi(ab2)
}
x <- apply(X = data.frame(ab1 = as.integer(ab1),
ab2 = as.integer(ab2)),
MARGIN = 1,
FUN = min)
sum(!is.na(ab1) & !is.na(ab2))
} else {
x <- ab1
sum(!is.na(ab1))
}
.Call(`_AMR_rsi_calc_total`, x)
}
#' @rdname resistance
@ -370,24 +374,8 @@ rsi_df <- function(tbl,
all_vars(. %in% c("S", "R", "I"))) %>%
nrow()
} else if (length(ab) == 3) {
if (interpretations_to_check != 'S') {
warning('`interpretation` not set to S or I/S, albeit analysing a combination therapy.', call. = FALSE)
}
numerator <- tbl %>%
filter_at(vars(ab[1], ab[2], ab[3]),
any_vars(. == interpretations_to_check)) %>%
filter_at(vars(ab[1], ab[2], ab[3]),
all_vars(. %in% c("S", "R", "I"))) %>%
nrow()
denominator <- tbl %>%
filter_at(vars(ab[1], ab[2], ab[3]),
all_vars(. %in% c("S", "R", "I"))) %>%
nrow()
} else {
stop('Maximum of 3 drugs allowed.')
stop('Maximum of 2 drugs allowed.')
}
# build text part

123
R/trends.R
View File

@ -1,123 +0,0 @@
#' Detect trends using Machine Learning
#'
#' Test text
#' @param data a \code{data.frame}
#' @param threshold_unique do not analyse more unique \code{threshold_unique} items per variable
#' @param na.rm a logical value indicating whether \code{NA} values should be stripped before the computation proceeds.
#' @param info print relevant combinations to console
#' @return A \code{list} with class \code{"trends"}
#' @importFrom stats na.omit
#' @importFrom broom tidy
# @export
trends <- function(data, threshold_unique = 30, na.rm = TRUE, info = TRUE) {
cols <- colnames(data)
relevant <- list()
count <- 0
for (x in 1:length(cols)) {
for (y in 1:length(cols)) {
if (x == y) {
next
}
if (n_distinct(data[, x]) > threshold_unique | n_distinct(data[, y]) > threshold_unique) {
next
}
count <- count + 1
df <- data %>%
group_by_at(c(cols[x], cols[y])) %>%
summarise(n = n())
n <- df %>% pull(n)
# linear regression model
lin <- stats::lm(1:length(n) ~ n, na.action = ifelse(na.rm == TRUE, na.omit, NULL))
res <- list(
df = df,
x = cols[x],
y = cols[y],
m = base::mean(n, na.rm = na.rm),
sd = stats::sd(n, na.rm = na.rm),
cv = cv(n, na.rm = na.rm),
cqv = cqv(n, na.rm = na.rm),
kurtosis = kurtosis(n, na.rm = na.rm),
skewness = skewness(n, na.rm = na.rm),
lin.p = broom::tidy(lin)[2, 'p.value']
#binom.p <- broom::tidy(binom)[2, 'p.value']
)
include <- TRUE
# ML part
if (res$cv > 0.25) {
res$reason <- "cv > 0.25"
} else if (res$cqv > 0.75) {
res$reason <- "cqv > 0.75"
} else {
include <- FALSE
}
if (include == TRUE) {
relevant <- c(relevant, list(res))
if (info == TRUE) {
# minus one because the whole data will be added later
cat(paste0("[", length(relevant), "]"), "Relevant:", cols[x], "vs.", cols[y], "\n")
}
}
}
}
cat("Total of", count, "combinations analysed;", length(relevant), "seem relevant.\n")
class(relevant) <- 'trends'
relevant <- c(relevant, list(data = data))
relevant
}
# @exportMethod print.trends
# @export
#' @noRd
print.trends <- function(x, ...) {
cat(length(x) - 1, "relevant trends, out of", length(x$data)^2, "\n")
}
# @exportMethod plot.trends
# @export
#' @noRd
# plot.trends <- function(x, n = NULL, ...) {
# if (is.null(n)) {
# oask <- devAskNewPage(TRUE)
# on.exit(devAskNewPage(oask))
# n <- c(1:(length(x) - 1))
# } else {
# if (n > length(x) - 1) {
# stop('trend unavailable, max is ', length(x) - 1, call. = FALSE)
# }
# oask <- NULL
# }
# for (i in n) {
# data <- x[[i]]$df
# if (as.character(i) %like% '1$') {
# suffix <- "st"
# } else if (as.character(i) %like% '2$') {
# suffix <- "nd"
# } else if (as.character(i) %like% '3$') {
# suffix <- "rd"
# } else {
# suffix <- "th"
# }
# if (!is.null(oask)) {
# cat(paste("Coming up:", colnames(data)[1], "vs.", colnames(data)[2]), "\n")
# }
# print(
# ggplot(
# data,
# aes_string(x = colnames(data)[1],
# y = colnames(data)[3],
# group = colnames(data)[2],
# fill = colnames(data)[2])) +
# geom_col(position = "dodge") +
# theme_minimal() +
# labs(title = paste(colnames(data)[1], "vs.", colnames(data)[2]),
# subtitle = paste0(i, suffix, " trend"))
# )
# }
# }

23
man/trends.Rd
View File

@ -1,23 +0,0 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/trends.R
\name{trends}
\alias{trends}
\title{Detect trends using Machine Learning}
\usage{
trends(data, threshold_unique = 30, na.rm = TRUE, info = TRUE)
}
\arguments{
\item{data}{a \code{data.frame}}
\item{threshold_unique}{do not analyse more unique \code{threshold_unique} items per variable}
\item{na.rm}{a logical value indicating whether \code{NA} values should be stripped before the computation proceeds.}
\item{info}{print relevant combinations to console}
}
\value{
A \code{list} with class \code{"trends"}
}
\description{
Test text
}

12
src/RcppExports.cpp
View File

@ -29,22 +29,10 @@ BEGIN_RCPP
return rcpp_result_gen;
END_RCPP
}
// rsi_calc_total
int rsi_calc_total(DoubleVector x);
RcppExport SEXP _AMR_rsi_calc_total(SEXP xSEXP) {
BEGIN_RCPP
Rcpp::RObject rcpp_result_gen;
Rcpp::RNGScope rcpp_rngScope_gen;
Rcpp::traits::input_parameter< DoubleVector >::type x(xSEXP);
rcpp_result_gen = Rcpp::wrap(rsi_calc_total(x));
return rcpp_result_gen;
END_RCPP
}
static const R_CallMethodDef CallEntries[] = {
{"_AMR_rsi_calc_S", (DL_FUNC) &_AMR_rsi_calc_S, 2},
{"_AMR_rsi_calc_R", (DL_FUNC) &_AMR_rsi_calc_R, 2},
{"_AMR_rsi_calc_total", (DL_FUNC) &_AMR_rsi_calc_total, 1},
{NULL, NULL, 0}
};

27
src/rsi_calc.cpp
View File

@ -1,28 +1,21 @@
#include <Rcpp.h>
#include <functional> // for std::less, etc
#include <algorithm> // for count_if
// #include <functional> // for std::less_equal and std::greater_equal
// #include <algorithm> // for count_if
using namespace Rcpp;
// [[Rcpp::export]]
int rsi_calc_S(DoubleVector x, bool include_I) {
if (include_I == TRUE) {
return count_if(x.begin(), x.end(), bind2nd(std::less_equal<double>(), 2));
} else {
return count_if(x.begin(), x.end(), bind2nd(std::less<double>(), 2));
}
return count_if(x.begin(),
x.end(),
bind2nd(std::less_equal<double>(),
1 + include_I));
}
// [[Rcpp::export]]
int rsi_calc_R(DoubleVector x, bool include_I) {
if (include_I == TRUE) {
return count_if(x.begin(), x.end(), bind2nd(std::greater_equal<double>(), 2));
} else {
return count_if(x.begin(), x.end(), bind2nd(std::greater<double>(), 2));
}
}
// [[Rcpp::export]]
int rsi_calc_total(DoubleVector x) {
return count_if(x.begin(), x.end(), bind2nd(std::less_equal<double>(), 3));
return count_if(x.begin(),
x.end(),
bind2nd(std::greater_equal<double>(),
3 - include_I));
}

14
tests/testthat/test-clipboard.R
View File

@ -1,13 +1,19 @@
context("clipboard.R")
test_that("clipboard works", {
if (!clipr::clipr_available() & Sys.info()['sysname'] == "Linux") {
# try to support on X11, by setting the R variable DISPLAY
Sys.setenv(DISPLAY = "localhost:10.0")
}
skip_if_not(clipr::clipr_available())
clipboard_export(antibiotics)
expect_identical(antibiotics,
clipboard_import(date_format = "yyyy-mm-dd"))
expect_identical(as.data.frame(antibiotics, stringsAsFactors = FALSE),
clipboard_import())
clipboard_export(septic_patients[1:100,])
expect_identical(tbl_parse_guess(septic_patients[1:100,]),
clipboard_import(guess_col_types = TRUE))
expect_identical(as.data.frame(tbl_parse_guess(septic_patients[1:100,]), stringsAsFactors = FALSE),
clipboard_import(guess_col_types = TRUE, stringsAsFactors = FALSE))
})

6
tests/testthat/test-resistance.R
View File

@ -27,6 +27,12 @@ test_that("resistance works", {
combination_n = n_rsi(cipr, gent)) %>%
pull(combination_n),
c(138, 474, 170, 464, 183))
expect_warning(resistance(as.character(septic_patients$amcl)))
expect_warning(susceptibility(as.character(septic_patients$amcl)))
expect_warning(susceptibility(as.character(septic_patients$amcl,
septic_patients$gent)))
})
test_that("prediction of rsi works", {