Вложено для и если циклы в R - PullRequest
Новая
       7

Вложено для и если циклы в R

0 голосов
/ 24 апреля 2018

Я пытаюсь написать код функции для клинического теста в R. Мои навыки R довольно ржавые, и я был бы очень признателен за любую помощь с этим.

Функция, которую я пытаюсь написать, принимает 31 значение (в клиническом тесте есть 31 вопрос, который заполняет пациент). Эти 31 значение затем оцениваются отдельно (большинство вопросов имеют разные диапазоны), а затем объединяются, чтобы получить средневзвешенное значение для различных параметров.

Диапазоны оценки:

для Q 1 (определяется как x1) - умножить ответ на 10

для Q 2,6,5,9 - (по шкале 6) оцените их как
1 - 100
2 - 80
3 - 60
4 - 40
5 - 20
6 - 0.

для Q 3,4,7,8,10,11,12,13,16,17,18 (по шкале 6)
1 - 0
2 - 20
3 - 40
4 - 60
5 - 80
6 - 100

для Q 14, 25, 26, 27, 28, 29, 30 (по шкале 5)
1 - 100
2 - 75
3 - 50
4 - 25
5 - 0

для Q 19,20 (по шкале 5)
1 - 0
2 - 25
3 - 50
4 - 75
5 - 100

для Q 15, 21, 23, 24 (по шкале 4)
1 - 0
2 - 33,3
3 - 66,7
4 - 100

для Q 22 * ​​1045 * 1 - 0
2 - 50
3 -100 

qolie31 <- function(x1, x2, x3, ...){
  x1a <- x1*10 
  z <- c(x2, x5, x6, x9)  
  {for (i in z){
    if (i==1){x == 100}
    else if(i==2){x == 80}
    else if(i==3){x==60}
    else if(i==4){x==40}
    else if(i==5){x==20}
    else (i==6){x==0}
    z2 <- x
  }
}

Мои вопросы:

  1. Я использовал функцию ... в первой строке кода, чтобы определить, что мне нужны аргументы от x1 до x31. Моя конечная цель не состоит в том, чтобы определять их вручную от 1 до 31. Пожалуйста, кто-нибудь может сказать мне, как определить аргументы от x1 до x31, без ручной записи там

  2. Как сохранить новый счет в функции, чтобы я мог использовать его позже для анализа?

Ответы [ 3 ]

0 голосов
/ 24 апреля 2018

Вы можете использовать функцию mapvalues из пакета plyr. 

    rescaleq<- function(x){
    require(plyr)
    if (length(x) != 30) stop("Vector of 30 elements required")
    x[1]<- x[1]*10
    x[c(2, 5, 6, 9)]<- mapvalues(x[c(2, 5, 6, 9)], from = 1:6, to = seq(100, 0, by = -20))
    x[c(3,4,7,8,10,11,12,13,16,17,18)]<- mapvalues(x[c(3,4,7,8,10,11,12,13,16,17,18)], from  = 1:6, to = seq(0, 100, by = 20))
    x[c(14, 25, 26, 27, 28, 29, 30)]<- mapvalues(x[c(14, 25, 26, 27, 28, 29, 30)], from = 1:5, to = seq(100, 0, by = -25))
    x[c(19, 20)]<- mapvalues(x[c(19, 20)], from = 1:5, to = seq(0, 100, by = 25))
    x[c(5, 21, 23, 24)]<- mapvalues(x[c(5, 21, 23, 24)], from = 1:4, to = seq(0, 100, length.out = 4))
     x[22]<- mapvalues(x[22], from = 1:3, to = seq(0, 100, by = 50))
    return(round(x, 2))
}

И проверить ее с некоторыми данными: 

> xvector <- sample.int(3, 31, replace=T)
> xvector
# [1] 2 1 3 2 2 3 2 1 1 3 1 3 1 1 1 1 2 1 3 1 1 2 1 1 2 2 3 1 3 3 
> rescaleq(xvector[-31]) # Note that below, these are messages NOT errors or warnings
#The following `from` values were not present in `x`: 4, 5, 6
#The following `from` values were not present in `x`: 4, 5, 6
#The following `from` values were not present in `x`: 4, 5
#The following `from` values were not present in `x`: 2, 4, 5
#The following `from` values were not present in `x`: 3, 4
#The following `from` values were not present in `x`: 1, 3
# [1]  20.00 100.00  80.00  60.00 100.00  40.00  20.00  20.00   0.00  40.00   0.00  40.00
#[13]   0.00   0.00  20.00   0.00 100.00  75.00  75.00  50.00 100.00  50.00  50.00  50.00
#[25]   0.00  33.33   0.00   0.00   0.00  50.00

Если вы хотите удалитьсообщения, сгенерированные mapvalues, попробуйте обернуть вокруг них suppressMessages, например suppressMessages(mapvalues(x[c(2, 5, 6, 9)], from = 1:6, to = seq(100, 0, by = -20))) и т. д.

0 голосов
/ 24 апреля 2018

Другой способ, на этот раз с использованием tidyverse и справочной таблицы: 

library(tidyverse)

data = "
1                             | 10
2,6,5,9                       | 100,80,60,40,20,0
3,4,7,8,10,11,12,13,16,17,18  | 0,20,40,60,80,100
14, 25, 26, 27, 28, 29, 30    | 100,75,50,25,0
19,20                         | 0,25,59,75,100
15, 21, 23, 24                | 0, 33.3, 66.7, 100
22                            | 0,50,100
"

df <- read.table(text = data, sep = '|', 
                 stringsAsFactors = F, 
                 col.names = c('q', 'factor'),
                 strip.white = T)

# create the lookup table
# save it somewhere
# as we only need to generate it once
lookup <- df %>%
  separate_rows(q, sep = ',') %>%
  separate_rows(factor, sep = ',', convert = T) %>%
  group_by(q) %>%
  mutate(item = 1:n()) %>%
  ungroup()

# calculate the score
calc_score <- function(x) {
  score <- 0
  for (i in seq_along(x)) {
    f <- lookup %>% filter(q == i, item == x[i]) %>% select(factor) %>% pull()
    score <- score + i * f
  }
  score
}

v <- c(1,4,3)
(score <- calc_score(v))

Это дает оценку 210 для этого примера.

0 голосов
/ 24 апреля 2018

Как правило, вы можете захватить произвольное количество аргументов с помощью ..., используя list(...).Подробнее в этот другой вопрос .Тем не менее, это обычно лучше, когда вы думаете, что не будете знать, сколько аргументов будет предоставлено, и вы все равно захотите это обработать.В этом случае вы знаете, что должно быть 31 ответ, поэтому ... не подходит.Вместо этого вы должны попытаться сохранить ваши ответы в векторе 31 длины и указать их в качестве аргумента.Пример ниже.Здесь я создаю коротких вкладчиков, чтобы преобразовать каждую группу ответов в соответствии с изложенными вами правилами.Здесь используются математические функции R, которые, на мой взгляд, чище (и быстрее?), Чем использование операторов if для всего.Затем мы просто применяем преобразование к каждому набору ответов и присваиваем их выходным баллам.Пример с некоторыми случайными ответами 1-3 показан.

Если вы беспокоитесь о том, что опечатки могут быть проблемой, я включил некоторый закомментированный код, используя assert_that для проверки ошибок.Внутри каждой функции score_ вы можете проверить, что ответ находится в правильном диапазоне, например, ответ на вопрос 22 не должен иметь значение 4.

Для последней части вам не нужно включатьназначение внутри функции.Просто убедитесь, что он возвращает то, что вы хотите, и выполняйте присваивание при вызове функции, как показано ниже. 

eg_ans <- sample.int(3, 31, replace = TRUE)

transform_scores <- function(answers){
  # assertthat::assert_that(
  #   length(answers) == 31,
  #   msg = "There are not 31 values in input vector"
  # )
  score1 <- function(ans) ans * 10
  score6a <- function(ans) (6 - ans) * 20
  score6b <- function(ans) (ans - 1) * 20
  score5a <- function(ans) (5 - ans) * 25
  score5b <- function(ans) (ans - 1) * 25
  score4 <- function(ans) (ans - 1) * (100 / 3)
  score3 <- function(ans) (ans - 1) * 50

  scores <- numeric(31)
  scores[1] <- score1(answers[1])
  scores[c(2, 5:6, 9)] <- score6a(answers[c(2, 5:6, 9)])
  scores[c(3:4, 7:8, 10:13, 16:18)] <- score6b(answers[c(3:4, 7:8, 10:13, 16:18)])
  scores[c(14, 25:30)] <- score5a(answers[c(14, 25:30)])
  scores[19:20] <- score5b(answers[19:20])
  scores[c(15, 21, 23:24)] <- score4(answers[c(15, 21, 23:24)])
  scores[22] <- score3(answers[22])
  return(scores)
}

eg_scores <- transform_scores(eg_ans)
eg_scores
#>  [1]  30.00000  60.00000   0.00000  20.00000 100.00000 100.00000   0.00000
#>  [8]  20.00000  60.00000  20.00000   0.00000  40.00000   0.00000  75.00000
#> [15]  66.66667   0.00000   0.00000  20.00000  50.00000  50.00000  66.66667
#> [22] 100.00000   0.00000  33.33333 100.00000  75.00000 100.00000 100.00000
#> [29] 100.00000  50.00000   0.00000

Создано в 2018-04-24 с помощью пакета prex (v0.2.0).

...