R - увеличить область под кривой для нескольких сценариев

Question

Учитывая, что у меня есть два вектора, один из которых называется residues, а второй - scores, который имеет 31 балл, по одному на каждый остаток, все положительные числа. Для иллюстрации два вектора были получены, как показано ниже:

residues <- 1:31 
scores <- runif(n = 31, min = 0.35, max = 3.54) 

Я рассматриваю случайную последовательность только для иллюстрации. Если я сюжет residues умноженной scores у меня будет следующим графический:

То, что я хочу сделать, это следующее: я буду рассматривать конкретные комбинации из 15 остатков (далее именуются 15-мерный), пропуская один вычет (т.е. 1:15, 2:16, 3:17 до 17:31), и я хочу рассчитать площадь под кривой (AUC) для всех этих 17 комбинаций. Моя конечная цель - выбрать 15mer, у которого самая высокая AUC.

AUC может быть рассчитан с использованием функции rollmean из пакета зоопарка, как показано в this question. Однако, поскольку в этом примере у меня есть 17 возможных комбинаций, я пытаюсь найти сценарий для автоматизации процесса. Спасибо заранее.

Answer 1

library(zoo) 

set.seed(555) 
residues <- 1:31 
scores <- runif(n = 31, min = 0.35, max = 3.54) 


which.max(sapply(1:17, function(x){sum(diff(residues[x:(x+14)])*rollmean(scores[x:(x+14)],2))})) 
# result 7 i.e. 7:21 

или

sapply(1:17, function(x){sum(diff(residues[x:(x+14)])*rollmean(scores[x:(x+14)],2))}) # gives you the AUCs 
# result [1] 28.52530 29.10203 28.52847 27.65325 27.19925 28.77782 29.29373 28.13133 28.23705 27.68724 25.75294 25.27226 25.44963 25.81201 25.49907 23.48632 
     #[17] 22.45763 

или с пользовательской функцией

f_AUC <- function(x, y, lngth){ 
    sapply(1:(length(x)-lngth+1), function(z) sum(diff(x[z:(z+lngth-1)])*rollmean(y[z:(z+lngth-1)],2))) 
} 

f_AUC(x=residues, y=scores, lngth=15) 

Answer 2

Вот следующая функция я использовал

scores <- runif(n = 31, min = 0.35, max = 3.54) 

fun <- function(dat, n) { 
    require(zoo) 
    N <- which(max(rollmean(dat, n)) == rollmean(dat, n)) 
    output <- matrix(0, length(N), n) 
    for (i in 1:length(N)) { 
    output[i, ] <- dat[N[i]:(N[i] + n - 1)] 
    } 
    output 
} 

fun(scores, 15) 

Позволяет запустить хотя это наизнанку

rollmean(dat, n) 

из пакета зоопарка, как вы упомянули дает нам качению среднее из которых мы

max(rollmean(dat, n)) 

находит максимальное среднее значение прокатки

max(rollmean(dat, n)) == rollmean(dat, n) 

возвращает TRUE/FALSE вектор, какой из прокатных средств равны максимальному

N <- which(max(rollmean(dat, n)) == rollmean(dat, n)) 

возвращает индексы максимумов. В зависимости от ваших данных вы можете иметь несколько последовательностей, которые получают максимальные мы решили вернуть все из них со следующей петлей

for (i in 1:length(N)) { 
    output[i, ] <- dat[N[i]:(N[i] + n -1)] 
} 

к результату:

set.seed(12345) 
scores <- runif(n = 31, min = 0.35, max = 3.54) 

fun(scores, 15) 
     [,1]  [,2]  [,3]  [,4]  [,5] [,6] 
[1,] 1.588179 1.633928 0.9208938 3.385791 1.797393 1.39234 
     [,7]  [,8]  [,9] [,10] [,11] [,12] 
[1,] 3.429675 2.606867 2.406091 1.593553 2.578354 2.085545 
     [,13] [,14] [,15] 
[1,] 1.07243 1.895739 2.879693 

fun(rpois(1000, 1), 10) 
    [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] 
[1,] 1 1 4 2 1 1 3 3 2  2 
[2,] 1 4 2 1 1 3 3 2 2  1 
[3,] 4 2 1 1 3 3 2 2 1  1