Senhores, bom dia.<br><br>A simulação que pretendo realizar implementei através das funções que estão listadas abaixo, a combinations é do pacote gtools, necessáriamente queria só melhorar o tempo de processamento do função dialelo, especificamente no for() que corre pela matriz de combinações. Fui rodando odas as etapas da função e detectei justamente nesse ponto o gargalo do calculo.<br>
<br>att,<br>Fernando H<br><br># _____________________________________________________________________<br>#_ OK<br>#_ Função para cálculo do valor genotípico<br>#_ Parâmetros:  indv = indvíduo sob análise<br>#                gmd = grau médio de dominância<br>
#______________________________________________________________________<br><br><a href="http://soma.vg">soma.vg</a> <- function(indv, gmd){ # argumentos da função<br>  h <- gmd # atribui o desvio de dominância ao heterozigoto<br>
  gen <- numeric() # cria um vetor qualquer - armazena os valores genotípicos<br>  for(i in 1:length(indv)){ # 'laço' - passa a regra p/ cada loco<br>    # se o loco for igual a 'r' (recessivo) valor genotípico recebe -1<br>
    # se o loco for igual a 'h' (heterozigoto) valor genotípico recebe gmd<br>    # se o loco for igual a 'd' (dominante) valor genotípico recebe 1<br>    if(indv[i] == 'r') {<br>      gen[i] <- -1<br>
    } else {<br>      if(indv[i] == 'h') gen[i] <- h else gen[i] <- 1<br>    }<br>  }<br>  return(sum(gen)) # retorna a soma dos valores genotípcos por loco<br>}<br><br># _____________________________________________________________________<br>
#_ OK<br>#_ Função para regra da segregação<br>#_ Parâmetros:  pai e mãe = indvíduos sob análise (cruzando)<br>#______________________________________________________________________<br><br>segregacao <- function(pai, mae) { # argumentos da função<br>
  filho <- numeric() # cria um vetor qualquer - armazena os valores genotípicos do filho<br>  for(i in 1:length(pai)) { # 'laço' - passa a regra de segregação p/ cada loco<br>    # se ambos pais são homozigotos dominantes (d), filho é dominante (d)<br>
    # se um pai é dominante e o outro é heterozigoto (h) filho pode ser 'h' ou 'd' 50% p/ cada<br>    # se ambos pais são heterozigoto segregação 1:2:1 'd', 'h', e 'r'<br>    # se um pai é dominante e o outro é recessivo filho é heterozigoto<br>
    # se um pai é reccessivo e o outro é heterozigoto filho pode ser 'r' ou 'r' 50% p/ cada<br>    # se ambos pais são recessivos filho é recessivo<br>    if(pai[i] == 'd' & mae[i] == 'd') filho[i] <- 'd'<br>
    if(pai[i] == 'd' & mae[i] == 'h' | pai[i] == 'h' & mae[i] == 'd'){<br>      u <- runif(1)<br>      if(u <= .5) filho[i] <- 'd' else filho[i] <- 'h'<br>
    }<br>    if(pai[i] == 'd' & mae[i] == 'r' | pai[i] == 'r' & mae[i] == 'd'){<br>      filho[i] <- 'h'<br>    }<br>    if(pai[i] == 'h' & mae[i] == 'h'){<br>
      u <- runif(1)<br>      if(u <= .25) filho[i] <- 'd' else<br>      if((u > .25) & (u <= .75)) filho[i] <- 'h' else<br>      filho[i] <- 'r'<br>    }<br>    if(pai[i] == 'h' & mae[i] == 'r' | pai[i] == 'r' & mae[i] == 'h'){<br>
      u <- runif(1)<br>      if(u <= .5) filho[i] <- 'h' else filho[i] <- 'r'<br>    }<br>    if(pai[i] == 'r' & mae[i] == 'r') filho[i] <- 'r'<br>  }<br>  return(filho) # retorna a constituição genética do filho do cruzamento<br>
}<br><br># _____________________________________________________________________<br>#_ OK<br>#_ Função para fazer cruzamentos<br>#_ Parâmetros:    pai e mae = indvíduos, 'pai' e 'mãe'<br>#                     prole = número de indivíduos na progênie     <br>
#______________________________________________________________________<br><br>cruz<-function(pai, mae, prole){ # argumentos da função<br>  progenie <- matrix(NA, ncol = length(pai), nrow = prole) # cria matriz qualquer [prole,g] - armazena a prole<br>
  for(i in 1:prole) { #'laço' - cria prole filhos do cruzamento<br>    progenie[i,] <- segregacao(pai, mae)<br>  }<br>  return(progenie) # retorna a prole do cruzamento<br>}<br><div class="gmail_quote"><br><blockquote class="gmail_quote" style="border-left: 1px solid rgb(204, 204, 204); margin: 0pt 0pt 0pt 0.8ex; padding-left: 1ex;">
<div><div class="h5">
><br>
> # _____________________________________________________________________<br>
> #<br>
> #_ Função para fazer um dialelo<br>
> #_ Parâmetros:  pais = indivíduos selecionados na população anterior<br>
> #          população = população dos pais<br>
> #              prole = tamanho das progênies<br>
> #                 h2 = herdabilidade do caráter<br>
> #                gmd = grau médio de dominância<br>
> #______________________________________________________________________<br>
> dialelo <- function(pais, populacao, prole, h2, gmd) { # argumentos da<br>
> função<br>
>   combinacoes <- combinations(length(pais), 2, v = pais) # cria todas as<br>
> combinações híbridas<br>
>   progenies <- vector('list', length = nrow(combinacoes)) # cria a<br>
> estrutura<br>
> das progênies<br>
>   id <- cbind(rep(c(1:nrow(combinacoes)), each = prole),<br>
>               rep(combinacoes[,1], each = prole),<br>
>               rep(combinacoes[,2], each = prole)) # cria a estrutura de<br>
> identificação das progênies<br>
>   g <- ncol(populacao) - 5 # verifica o número de genes envolvidos<br>
>   for(i in 1:nrow(combinacoes)) { # 'laço' -  para executar todos<br>
> cruzamentos<br>
>     cruz.i <- cruz(populacao[combinacoes[i,1],4:(3 + g)],<br>
>                    populacao[combinacoes[i,2],4:(3 + g)],prole) # aplica a<br>
> função 'cruz'<br>
>     progenies[[i]] <- cruz.i # armazena a prole de cada cruzamento<br>
>   }<br>
>   dialelo <- as.data.frame(do.call(rbind, progenies)) # monta a planilha<br>
> com<br>
> o dialelo<br>
>   vg <- apply(dialelo, 1, <a href="http://soma.vg" target="_blank">soma.vg</a>, gmd = gmd) # calcula os valores<br>
> genotípicos totais por indivíduo<br>
>   varg <- var(vg) # calcula a variância genética<br>
>   fen <- vg + rnorm(nrow(dialelo), mean = 0, sqrt(varg * (1 - h2) / h2)) #<br>
> atribui o desvio fenotípico<br>
>   resp <- cbind(id, dialelo, vg, fen) # monta a planilha com os resultados<br>
> do dialelo<br>
>   names(resp) <- c('fami', 'pai', 'mae', 1:g, 'vg', 'fen') # atribui os<br>
> nomes as colunas da planilha<br>
>   return(resp) # retorna o dialelo<br>
> }<br></div></div></blockquote></div>