tidyverse/dplyrを使用して、観測値のヒストグラムを使用して観測されない値を再割り当てします。

Question

えさは現場での電気漁業操作中にサンプリングされました。ほとんどが測定された（バッチ= S）、一部はなかった（バッチ= L）。 。 私は、個々の "S"測定で観測された最も近い10mm値と サイズ構造を使用して、Lバッチ内に欠けているウナギを再割り当てしたいと思います。

eel <- structure(list(op = c(529L, 529L, 529L, 529L, 529L, 529L, 529L, 
      529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 
      529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 
      529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 
      529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 
      529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 
      529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 
      529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 529L, 
      529L, 529L, 529L, 529L, 529L, 529L, 545L, 545L, 545L, 545L, 545L, 
      545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 
      545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 
      545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 545L, 
      545L, 545L), size = c(101L, 103L, 110L, 112L, 115L, 119L, 120L, 
      121L, 121L, 121L, 123L, 127L, 128L, 129L, 135L, 140L, 146L, 147L, 
      147L, 148L, 150L, 152L, 152L, 155L, 159L, 160L, 164L, 164L, 164L, 
      175L, 180L, 184L, 190L, 192L, 193L, 213L, 216L, 227L, 233L, 235L, 
      240L, 253L, 256L, 278L, 287L, 289L, 303L, 307L, 312L, 323L, 80L, 
      82L, 92L, 93L, 100L, 112L, 114L, 120L, 121L, 122L, 128L, 131L, 
      147L, 149L, 151L, 156L, 159L, 161L, 164L, 165L, 167L, 168L, 172L, 
      195L, 222L, 228L, 242L, 257L, 265L, 265L, 275L, 290L, 294L, 294L, 
      307L, 310L, 315L, 330L, 374L, 80L, 143L, 176L, 165L, 141L, 139L, 
      93L, 138L, 129L, 143L, 139L, 126L, 84L, 126L, 119L, 129L, 111L, 
      112L, 426L, 188L, 186L, 293L, 235L, 188L, 173L, 177L, 176L, 165L, 
      165L, 166L, 141L, 231L, 168L, 167L, 186L, 168L, 161L, 187L, 129L, 
      155L, 84L), batch = c("S", "S", "S", "S", "S", "S", "S", "S", 
      "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", 
      "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", 
      "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", 
      "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", 
      "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", 
      "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", 
      "S", "S", "S", "L", "S", "S", "S", "S", "S", "S", "S", "S", "S", 
      "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", 
      "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", "S", 
      "S", "S", "S", "S", "L"), number = c(0L, 0L, 0L, 0L, 0L, 0L, 
      0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
      0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
      0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
      0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
      0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
      0L, 0L, 0L, 133L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
      0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 
      0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 0L, 67L)), .Names = c("op", 
     "size", "batch", "number"), row.names = 4:133, class = "data.frame") 

私は（すべての観測値は、休憩の範囲内に収まっていることを確認します） 次の関数を使用して、私のサイズの構造からデータを抽出し、ヒストグラムを使用してtidyverseでそれを行うことを試みました。新しいサイズを10 mmごとに配置したい。

fn<-function(x) hist(x, 
     breaks=seq(min(plyr::round_any(x, 10,f=floor)),plyr::round_any(max(x),10,f=ceiling),by=10), 
     plot=FALSE) 

それから私は、次のコード

hist <- eel%>% 
    filter(batch=='S') %>% 
    select (size,op) %>% 
    group_by(op) %>% 
    by_slice(~fn(.x$size)) 

を適用するここで私はbreaksとcountsと.outの列のヒストグラムを持っている、と私は は私のデータフレーム内の新しい行を作成したいと考えたものを使用しました。どんな助けでも大歓迎です。

Answer 1

私は方法を見つけました、おそらく最高ではない、私はbrowser引数を使って詳細を作りました。難しい部分の1つは、再割り当てされた数が整数である必要があり、クラスごとのパーセンテージから発行された数値を丸めるときに、いくつかのカウントが追加または失われることです。だから私はいくつかのウナギをサイズ構造にランダムに割り当てなければなりませんでした。許容誤差を機械化するには、引数sample(1:nrow(df),rr)が機能せず、丸めなければならなかったrr。関数mapとmap2を使用しようとしましたが、それを管理しなかったので、他の簡単な方法であれば大丈夫です。

group_sample <-  
    eel%>%  
    filter(batch=='L')%>% 
    select (op,number) 


individual_sample <- 
    eel%>% 
    filter(batch=='S') %>% 
    select (size,op)%>% 
    group_by(op) %>% 
    by_slice(~fn(.x$size)) %>% 
    rename(hist=.out) 

reassigned_sample<- inner_join(individual_sample,group_sample,by=c("op")) %>% 
    by_row(..f=function(this_row){ 
      #browser() 
      # frequencies 
      vec <-this_row["hist"][[1]][[1]]$counts/sum(this_row["hist"][[1]][[1]]$counts)*pull(this_row["number"]) 
      # numbers are rounded, but there is a problem with sum 
      roundvec <- round(vec) 
      sumvec <- sum(vec) 
      sumroundvec <- sum(roundvec) 
      # difference between rounded numbers and numbers 
      rr <- sumroundvec-sumvec 
      # creation du jeu de données ressemblant au tableau de départ (moins id première colonne) 
      df <- data.frame("op"=pull(this_row["op"]), 
       "size"=this_row["hist"][[1]][[1]]$mids-5, 
       "batch"="SL", 
       "number"=roundvec 
      ) 
      # remove lines with 0 number 
      df<-df[df$number>0,] 
      if (rr >0) { 
      # randomly removing eels from some samples 
      # round(rr) necessary otherwise might not be exact integer 
      sss <- sample(1:nrow(df),round(rr)) 
      df[sss,"number"]<-df[sss,"number"]-1 
      # randomly adding eels for some samples 
      } else if (rr <0){    
      sss<-sample(1:nrow(df),round(-rr)) 
      df[sss,"number"]<-df[sss,"number"]+1 
      } else { 
      # do nothing 
      } 
      stopifnot(round(sum(df$number))==round(sumvec)) 
      return(df)   
     }) %>% 
    rename(table=.out) 

bind_rows(reassigned_sample$table) 


op size batch number 
1 529 80 SL  3 
2 529 90 SL  4 
3 529 100 SL  4