pmap не работает при использовании mutate и case_when - PullRequest
Новая
       12

pmap не работает при использовании mutate и case_when

0 голосов
/ 28 декабря 2018

У меня есть смоделированный набор данных, где каждая строка представляет собой отдельную птицу, и я написал несколько функций, которые определяют, живет ли каждый человек или умирает.Условия выживания индивидуума зависят от его возрастного класса (AHY или HY) и его пола (M или F).Я создал функцию для каждой комбинации возраста / пола и использую pmap_chr внутри mutate / case_when, которая должна заполнить столбец с именем status.В моем коде это дает значение «живи» или «умри».Вот сокращенная версия моего набора данных: 

library(tidyverse)
agents <- structure(list(id = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 
13, 14, 15, 16, 17, 18), sex = c("F", "F", "F", "F", "F", "M", 
"M", "M", "M", "M", "F", "F", "M", "M", "M", "M", "M", "M"), 
    class = c("AHY", "AHY", "AHY", "AHY", "AHY", "AHY", "AHY", 
    "AHY", "AHY", "AHY", "HY", "HY", "HY", "HY", "HY", "HY", 
    "HY", "HY"), hDateCtr = c(-0.84852029241304, 0.558881154137435, 
    -0.909711659654365, 1.21158907137824, -0.56296057862019, 
    -0.0938267631033649, -1.54202245448139, -0.216209497586015, 
    1.33397180586089, 1.06880921448181, -0.935414346693485, -0.935414346693485, 
    -0.935414346693485, -0.935414346693485, 0.935414346693485, 
    0.935414346693485, 0.935414346693485, 0.935414346693485), 
    aDateCtr = c(-1.13245629117638, 1.13245629117638, -0.490731059509763, 
    1.13245629117638, -0.641725231666613, 1.13245629117638, -1.13245629117638, 
    1.13245629117638, -0.490731059509763, -0.641725231666613, 
    NA, NA, NA, NA, NA, NA, NA, NA), selfOrig = c("imm", "imm", 
    "imm", "imm", "imm", "imm", "imm", "imm", "imm", "imm", "local", 
    "local", "local", "local", "local", "local", "local", "local"
    ), sameSexOrig = c(NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, 
    "imm", "imm", "imm", "imm", "imm", "imm", "imm", "imm"), 
    success = c(TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, 
    TRUE, FALSE, FALSE, NA, NA, NA, NA, NA, NA, NA, NA), paired = c(TRUE, 
    TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, TRUE, FALSE, 
    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE)), class = c("tbl_df", 
"tbl", "data.frame"), row.names = c(NA, -18L))

# A tibble: 18 x 9
      id sex   class hDateCtr aDateCtr selfOrig sameSexOrig success paired
   <dbl> <chr> <chr>    <dbl>    <dbl> <chr>    <chr>       <lgl>   <lgl> 
 1     1 F     AHY    -0.849    -1.13  imm      NA          TRUE    TRUE  
 2     2 F     AHY     0.559     1.13  imm      NA          TRUE    TRUE  
 3     3 F     AHY    -0.910    -0.491 imm      NA          FALSE   TRUE  
 4     4 F     AHY     1.21      1.13  imm      NA          FALSE   TRUE  
 5     5 F     AHY    -0.563    -0.642 imm      NA          FALSE   TRUE  
 6     6 M     AHY    -0.0938    1.13  imm      NA          FALSE   TRUE  
 7     7 M     AHY    -1.54     -1.13  imm      NA          TRUE    TRUE  
 8     8 M     AHY    -0.216     1.13  imm      NA          TRUE    TRUE  
 9     9 M     AHY     1.33     -0.491 imm      NA          FALSE   TRUE  
10    10 M     AHY     1.07     -0.642 imm      NA          FALSE   TRUE  
11    11 F     HY     -0.935    NA     local    imm         NA      FALSE 
12    12 F     HY     -0.935    NA     local    imm         NA      FALSE 
13    13 M     HY     -0.935    NA     local    imm         NA      FALSE 
14    14 M     HY     -0.935    NA     local    imm         NA      FALSE 
15    15 M     HY      0.935    NA     local    imm         NA      FALSE 
16    16 M     HY      0.935    NA     local    imm         NA      FALSE 
17    17 M     HY      0.935    NA     local    imm         NA      FALSE 
18    18 M     HY      0.935    NA     local    imm         NA      FALSE

Вот пример написанных мной функций смертности, которые входят в pmap_chr.Все это работает нормально, если я запускаю приведенный ниже код для набора данных, который имеет один возрастной класс или пол: 

hDateEffect <- TRUE
winterTemp <- -3

# hatchling mortality -----------------------------------------------------

hatchMortInt <- -4.67
hatchMortIntSD <- 0.39
hatchMortBeta1 <- 0.6
hatchMortBeta1SD <- 0.27
hatchMortBeta2 <- 1.12
hatchMortBeta2SD <- 0.36
hatchMortBeta3 <- -0.3
hatchMortBeta3SD <- 0.16
hatchMortBeta4 <- -0.3
hatchMortBeta4SD <- 0.16


# male mortality ----------------------------------------------------------

maleMortInt <- -2.09
maleMortIntSD <- 0.32
maleMortBeta1 <- 0.81
maleMortBeta1SD <- 0.34
maleMortBeta2 <- -1.36
maleMortBeta2SD <- 0.84
maleMortBeta3 <- 1.67
maleMortBeta3SD <- 0.32


# female mortality --------------------------------------------------------

femMortInt <- -0.93
femMortIntSD <- 0.87
femMortBeta1 <- 1.59
femMortBeta1SD <- 0.35
femMortBeta2 <- -1.77
femMortBeta2SD <- 0.78

# hatch-year female 
HY_female_mortality <- function(hDateCtr, sameSexOrig, ...) {
  intercept <- rnorm(1, hatchMortInt, hatchMortIntSD)
  beta2 <- rnorm(1, hatchMortBeta2, hatchMortBeta2SD)
  beta4 <- rnorm(1, hatchMortBeta4, hatchMortBeta4SD)
  if(hDateEffect == TRUE) {
    beta3 <- rnorm(1, hatchMortBeta3, hatchMortBeta3SD)
  } else {
    beta3 <- 0
  }
  if (sameSexOrig == 'local') {
    linSurv <- intercept + beta2 + (beta3 * hDateCtr) + (beta4 * winterTemp)
  } else {
    linSurv <- intercept + (beta3 * hDateCtr) + (beta4 * winterTemp)
  }
  probSurv <- plogis(linSurv)
  randDraw <- runif(1, 0, 1)
  if (randDraw > probSurv) {
    val <- 'die'
    return(val)
  } else {
    val <- 'live'
    return(val)
  }
}

# hatch-year male
HY_male_mortality <- function(hDateCtr, sameSexOrig, ...) {
  intercept <- rnorm(1, hatchMortInt, hatchMortIntSD)
  beta1 <- rnorm(1, hatchMortBeta1, hatchMortBeta1SD) 
  beta2 <- rnorm(1, hatchMortBeta2, hatchMortBeta2SD)
  beta4 <- rnorm(1, hatchMortBeta4, hatchMortBeta4SD)
  if(hDateEffect == TRUE) {
    beta3 <- rnorm(1, hatchMortBeta3, hatchMortBeta3SD)
  } else {
    beta3 <- 0
  }
  if (sameSexOrig == 'local') {
    linSurv <- intercept + beta1 + beta2 + (beta3 * hDateCtr) + (beta4 * winterTemp)
  } else {
    linSurv <- intercept + beta1 + (beta3 * hDateCtr) + (beta4 * winterTemp)
  }
  probSurv <- plogis(linSurv)
  randDraw <- runif(1, 0, 1)
  if (randDraw > probSurv) {
    val <- 'die'
    return(val)
  } else {
    val <- 'live'
    return(val)
  }
}

# after-hatch-year mortality functions 
# after-hatch-year male 
AHY_male_mortality <- function(aDateCtr, success, selfOrig, ...) {
  intercept <- rnorm(1, maleMortInt, maleMortIntSD)
  beta1 <- rnorm(1, maleMortBeta1, maleMortBeta1SD) 
  beta3 <- rnorm(1, maleMortBeta3, maleMortBeta3SD)
  if(hDateEffect == TRUE) {
    beta2 <- rnorm(1, hatchMortBeta3, hatchMortBeta3SD)
  } else {
    beta2 <- 0
  }
  if (success == TRUE) {
    linSurv <- intercept + beta1 + (beta2 * aDateCtr)
  } else {
    linSurv <- intercept + (beta2 * aDateCtr)
  }
  if (selfOrig == 'local') {
    linSurv <- linSurv + beta3
  } else {
    linSurv <- linSurv
  }
  probSurv <- plogis(linSurv)
  randDraw <- runif(1, 0, 1)
  if (randDraw > probSurv) {
    val <- 'die'
    return(val)
  } else {
    val <- 'live'
    return(val)
  }
}

# after-hatch-year female 
AHY_female_mortality <- function(aDateCtr, success, ...) {
  intercept <- rnorm(1, femMortInt, femMortIntSD)
  beta1 <- rnorm(1, femMortBeta1, femMortBeta1SD) 
  beta2 <- rnorm(1, femMortBeta2, femMortBeta2SD)
  if (success == TRUE) {
    linSurv <- intercept + beta1 + (beta2 * aDateCtr)
  } else {
    linSurv <- intercept + (beta2 * aDateCtr)
  }
  probSurv <- plogis(linSurv)
  randDraw <- runif(1, 0, 1)
  if (randDraw > probSurv) {
    val <- 'die'
  } else {
    val <- 'live'
  }
  return(val)
}

Вот часть pmap_chr, которая не работает для всех возрастных и половых классовкомбинации: 

agents %>%
  mutate(
    status = case_when(
      class == 'HY' & sex == 'F' ~ pmap_chr(., HY_female_mortality),
      class == 'HY' & sex == 'M' ~ pmap_chr(., HY_male_mortality),
      class == 'AHY' & sex == 'M' ~ pmap_chr(., AHY_male_mortality),
      class == 'AHY' & sex == 'F' ~ pmap_chr(., AHY_female_mortality)
    )
  )

Но если я сделаю то же самое вместо этого для другого логического, называемого «успех» (то есть, если (успех == ИСТИНА)), то есть того, которое мне действительно нужно, чтобы условие было основано, оновыдает ошибку: 

Error in mutate_impl(.data, dots) : 
  Evaluation error: missing value where TRUE/FALSE needed.

Я в недоумении, почему эти функции работают по отдельности, но не для всего набора данных, содержащего все возрастные и половые классы.У меня есть примеры различных процессов (воспроизведение, иммиграция), где я делаю похожую вещь (беру набор данных, пишу функции, которые используются внутри pmap, которые, в свою очередь, находятся внутри case_when и mutate).

Ответы [ 2 ]

0 голосов
/ 29 декабря 2018

В ответ на комментарий А. Сулимана я изменил функции, чтобы вы могли видеть, что они дают определенное значение для каждого возрастного класса и пола: 

# hatch-year female 

HY_female_mortality <- function(hDateCtr, sameSexOrig, ...) {
  if(hDateEffect == TRUE) {
    val <- 'hatch effect on'
  } else {
    val <- 'hatch effect off'
  }
  if (sameSexOrig == 'local') {
    val <- paste0(val, ' and local')
  } else {
    val <- paste0(val, ' and immigrant')
  }
    return(paste0(val, ' and female HY'))
}

# hatch-year male
HY_male_mortality <- function(hDateCtr, sameSexOrig, ...) {
  if(hDateEffect == TRUE) {
    val <- 'hatch effect on'
  } else {
    val <- 'hatch effect off'
  }
  if (sameSexOrig == 'local') {
    val <- paste0(val, ' and local')
  } else {
    val <- paste0(val, ' and immigrant')
  }
  return(paste0(val, ' and male HY'))
}

# after-hatch-year mortality functions 
# after-hatch-year male 
AHY_male_mortality <- function(aDateCtr, success, selfOrig, ...) {
  if(hDateEffect == TRUE) {
    val <- 'hatch effect on'
  } else {
    val <- 'hatch effect off'
  }
  if (success == TRUE) {
    val <- paste0(val, ' and successful')
  } else {
    val <- paste0(val, ' and failed')
  }
  if (selfOrig == 'local') {
    val <- paste0(val, ' and local')
  } else {
    val <- paste0(val, ' and immigrant')
  }
  return(paste0(val, ' and male AHY'))
}

# after-hatch-year female 
AHY_female_mortality <- function(aDateCtr, success, ...) {
  if(hDateEffect == TRUE) {
    val <- 'hatch effect on'
  } else {
    val <- 'hatch effect off'
  }
  if (success == TRUE) {
    val <- paste0(val, ' and successful')
  } else {
    val <- paste0(val, ' and failed')
  }
  return(paste0(val, ' and female AHY'))
}

agents <- agents %>%
  split(.$class) 

agents$HY %>%
  mutate(
    status = case_when(
      sex == 'F' ~ pmap_chr(., HY_female_mortality),
      sex == 'M' ~ pmap_chr(., HY_male_mortality)
    )
  )

agents$AHY %>%
  mutate(
    status = case_when(
      sex == 'F' ~ pmap_chr(., AHY_female_mortality),
      sex == 'M' ~ pmap_chr(., AHY_male_mortality)
    )
  )

Разве это не ведет себя правильно? 

> agents$HY
# A tibble: 8 x 10
     id sex   class hDateCtr aDateCtr selfOrig sameSexOrig success paired status                                     
  <dbl> <chr> <chr>    <dbl>    <dbl> <chr>    <chr>       <lgl>   <lgl>  <chr>                                      
1    11 F     HY      -0.935       NA local    imm         NA      FALSE  hatch effect on and immigrant and female HY
2    12 F     HY      -0.935       NA local    imm         NA      FALSE  hatch effect on and immigrant and female HY
3    13 M     HY      -0.935       NA local    imm         NA      FALSE  hatch effect on and immigrant and male HY  
4    14 M     HY      -0.935       NA local    imm         NA      FALSE  hatch effect on and immigrant and male HY  
5    15 M     HY       0.935       NA local    imm         NA      FALSE  hatch effect on and immigrant and male HY  
6    16 M     HY       0.935       NA local    imm         NA      FALSE  hatch effect on and immigrant and male HY  
7    17 M     HY       0.935       NA local    imm         NA      FALSE  hatch effect on and immigrant and male HY  
8    18 M     HY       0.935       NA local    imm         NA      FALSE  hatch effect on and immigrant and male HY

> agents$AHY
# A tibble: 10 x 10
      id sex   class hDateCtr aDateCtr selfOrig sameSexOrig success paired status                                                   
   <dbl> <chr> <chr>    <dbl>    <dbl> <chr>    <chr>       <lgl>   <lgl>  <chr>                                                    
 1     1 F     AHY    -0.849    -1.13  imm      NA          TRUE    TRUE   hatch effect on and successful and female AHY            
 2     2 F     AHY     0.559     1.13  imm      NA          TRUE    TRUE   hatch effect on and successful and female AHY            
 3     3 F     AHY    -0.910    -0.491 imm      NA          FALSE   TRUE   hatch effect on and failed and female AHY                
 4     4 F     AHY     1.21      1.13  imm      NA          FALSE   TRUE   hatch effect on and failed and female AHY                
 5     5 F     AHY    -0.563    -0.642 imm      NA          FALSE   TRUE   hatch effect on and failed and female AHY                
 6     6 M     AHY    -0.0938    1.13  imm      NA          FALSE   TRUE   hatch effect on and failed and immigrant and male AHY    
 7     7 M     AHY    -1.54     -1.13  imm      NA          TRUE    TRUE   hatch effect on and successful and immigrant and male AHY
 8     8 M     AHY    -0.216     1.13  imm      NA          TRUE    TRUE   hatch effect on and successful and immigrant and male AHY
 9     9 M     AHY     1.33     -0.491 imm      NA          FALSE   TRUE   hatch effect on and failed and immigrant and male AHY    
10    10 M     AHY     1.07     -0.642 imm      NA          FALSE   TRUE   hatch effect on and failed and immigrant and male AHY
0 голосов
/ 28 декабря 2018

Разделение по возрастным категориям и использование аналогичного подхода решают проблему, но все еще не уверены, почему это не сработает оригинально ... 

agents <- agents %>%
    split(.$class) 

  agents$HY <- agents$HY %>%
    mutate(
      status = case_when(
        sex == 'F' ~ pmap_chr(., HY_female_mortality),
        sex == 'M' ~ pmap_chr(., HY_male_mortality)
      )
    )

  agents$AHY <- agents$AHY %>%
    mutate(
      status = case_when(
        sex == 'F' ~ pmap_chr(., AHY_female_mortality),
        sex == 'M' ~ pmap_chr(., AHY_male_mortality)
      )
    )

  agents <- agents %>%
    bind_rows()
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...