Извлечение значения из набора столбцов на основе минимального значения в другом наборе столбцов в R

Вы можете использовать несколько функций, чтобы сделать это эффективно.

Для столбца minScore я сначала проверяю, все ли значения NA находятся в столбцах, начинающихся со слова «оценка», затем помещаю NA в качестве вывода; в противном случае получите минимум по столбцам с именем «оценка», также удалив NA. Аналогичные шаги предприняты для столбца scoreAge.

data %>%
  rowwise() %>%
  mutate(
    minScore = if (all(is.na(c_across(starts_with("score"))))) {
      NA
    } else {
      min(c_across(starts_with("score")), na.rm = TRUE)
    },
    scoreAge = {
      score_cols <- c_across(starts_with("score"))
      age_cols <- c_across(starts_with("age"))
      if (all(is.na(score_cols))) {
        NA
      } else {
        min_score_index <- which.min(score_cols)
        age_cols[min_score_index]
      }
    }
  ) %>%
  ungroup()

Вы можете использовать rowwise, c_across и функцию аккуратного выбора starts_with. Учебник по rowwise, который также охватывает c_across. Документация по start_with.

library(dplyr)

# function to calculate minScore
calculate_min_score <- function(scores) {
  #if all scores are NA, return NA
  if (all(is.na(scores))) {
    return(NA_real_)
  } else { # otherwise return the min score
    return(min(scores, na.rm = TRUE))
  }
}

# function to calculate scoreAge
calculate_score_age <- function(scores, ages) {
  #If all scores are NA, return NA
  if (all(is.na(scores))) {
    return(NA_real_)
  } else { #Otherwise, find which score column number contains the min score
    min_score_idx <- which.min(scores)
    return(ages[min_score_idx]) #return the age column value associated with that score
  }
  
  
  
}


data %>%
  rowwise() %>%
  mutate(
    minScore = calculate_min_score(c_across(starts_with("score"))),
    scoreAge = calculate_score_age(
    scores = c_across(starts_with("score")), 
    ages = c_across(starts_with("age")))

  ) |> 
  ungroup() 

# A tibble: 5 × 17
  subject_id    age1  age2  age3  age4  age5  age6  age7 score1 score2 score3 score4 score5 score6 score7 minScore scoreAge
  <chr>        <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>  <dbl>    <dbl>    <dbl>
1 191-11173897    39    36     9    NA    NA    NA    NA   10.6    9.8   11.3     NA     NA     NA     NA      9.8       36
2 191-11561329     7    NA    NA    NA    NA    NA    NA   12.1   NA     NA       NA     NA     NA     NA     12.1        7
3 191-11700002    NA    NA    NA    NA    NA    NA    NA    9.8   NA     NA       NA     NA     NA     NA      9.8       NA
4 191-11857141    NA    NA    NA    NA    NA    NA    NA   NA     NA     NA       NA     NA     NA     NA     NA         NA
5 191-11933910    16    37    NA    NA    NA    NA    NA   10.6   11     NA       NA     NA     NA     NA     10.6       16

Вы можете изменить форму data, а затем применить filter, чтобы получить строку с наименьшим score для каждого subject_id.

library(dplyr)
library(tidyr)

data |>
  pivot_longer(-subject_id,
               names_to = c('measure', 'obs'),
               names_pattern = '([A-Za-z]+)(\\d+)',
               values_to = 'score') |>
  pivot_wider(names_from = measure, values_from = score) |> 
  filter(score == min(score, na.rm = TRUE), .by = subject_id)

#> # A tibble: 4 × 4
#>   subject_id   obs     age score
#>   <chr>        <chr> <dbl> <dbl>
#> 1 191-11173897 2        36   9.8
#> 2 191-11561329 1         7  12.1
#> 3 191-11700002 1        NA   9.8
#> 4 191-11933910 1        16  10.6

^{Created on 2024-05-20 with reprex v2.1.0}

Я использовал pivot_longer(), чтобы получить фрейм данных с одной строкой для каждого теста, содержащей возраст и балл. Рассчитывается минимальный балл для каждого subject_id и фильтруется, где score == minScore. (Я добавил distinct(), чтобы избежать ничьей при наименьшем количестве баллов.)

Затем соединитесь с исходными данными.

data %>% 
  pivot_longer(!matches("subject_id"), names_pattern = "(\\w+)(\\d+)", names_to = c(".value", "testid")) %>%
  mutate(minScore = min(score, na.rm = TRUE), .by = subject_id) %>%
  filter(minScore == score) %>%
  distinct(subject_id, score, .keep_all = TRUE) %>%
  select(subject_id, minScore, scoreAge=age) %>%
  right_join(data, by = "subject_id")

С rowwise и sort/order, чтобы избежать предупреждений, и Inf в случае всех NAs

library(dplyr)

data %>% 
  rowwise() %>% 
  mutate(minScore = sort(c_across(score1:score7))[1], 
         scoreAge = c_across(age1:age7)[order(c_across(score1:score7))[1]]) %>% 
  ungroup()

выход

# A tibble: 5 × 17
  subject_id    age1  age2  age3  age4  age5  age6  age7 score1 score2 score3
  <chr>        <dbl> <dbl> <dbl> <dbl> <dbl> <dbl> <dbl>  <dbl>  <dbl>  <dbl>
1 191-11173897    39    36     9    NA    NA    NA    NA   10.6    9.8   11.3
2 191-11561329     7    NA    NA    NA    NA    NA    NA   12.1   NA     NA  
3 191-11700002    NA    NA    NA    NA    NA    NA    NA    9.8   NA     NA  
4 191-11857141    NA    NA    NA    NA    NA    NA    NA   NA     NA     NA  
5 191-11933910    16    37    NA    NA    NA    NA    NA   10.6   11     NA  
  score4 score5 score6 score7 minScore scoreAge
   <dbl>  <dbl>  <dbl>  <dbl>    <dbl>    <dbl>
1     NA     NA     NA     NA      9.8       36
2     NA     NA     NA     NA     12.1        7
3     NA     NA     NA     NA      9.8       NA
4     NA     NA     NA     NA     NA         NA
5     NA     NA     NA     NA     10.6       16

Использование apply() один раз:

data[c("minScore", "scoreAge")] = 
  apply(data, 1L, \(x) { n = names(x)
  y = x[grepl("score", n)]; z = x[grepl("age", n)]
  i = if (all(is.na(y))) NA else which(y == min(y, na.rm = TRUE)) 
  l1 = if (is.na(i)) NA else y[i]; l2 = if (is.na(i)) NA else z[i]
  cbind(l1,l2) }) |> t() 

> data[c("minScore", "scoreAge")] 
  minScore scoreAge
1      9.8       36
2     12.1        7
3      9.8     <NA>
4     <NA>     <NA>
5     10.6       16

или (потенциально быстрее?)

f = \(d) {
  stopifnot(is.data.frame(d)); nd = names(d)
  a = as.matrix(d[grepl("score",  nd)]); b = as.matrix(d[grepl("age", nd)])
  l1 = matrix(a[order(row(a), a)], ncol = ncol(a), byrow = TRUE)[, 1L]
  l2 = mapply(\(i, j) b[i, j], seq(nrow(a)), Rfast::rowMins(a)) |> unname()
  cbind("minScore" = l1, "scoreAge" = l2)
}

> f(data)
     minScore scoreAge
[1,]      9.8       36
[2,]     12.1        7
[3,]      9.8       NA
[4,]       NA       NA
[5,]     10.6       16