[R-br] Res: Implementação em C

[Fernando Henrique Toledo]

Senhores, bom dia.

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.

att,
Fernando H

# _____________________________________________________________________
#_ OK
#_ Função para cálculo do valor genotípico
#_ Parâmetros:  indv = indvíduo sob análise
#                gmd = grau médio de dominância
#______________________________________________________________________

soma.vg <- function(indv, gmd){ # argumentos da função
  h <- gmd # atribui o desvio de dominância ao heterozigoto
  gen <- numeric() # cria um vetor qualquer - armazena os valores
genotípicos
  for(i in 1:length(indv)){ # 'laço' - passa a regra p/ cada loco
    # se o loco for igual a 'r' (recessivo) valor genotípico recebe -1
    # se o loco for igual a 'h' (heterozigoto) valor genotípico recebe gmd
    # se o loco for igual a 'd' (dominante) valor genotípico recebe 1
    if(indv[i] == 'r') {
      gen[i] <- -1
    } else {
      if(indv[i] == 'h') gen[i] <- h else gen[i] <- 1
    }
  }
  return(sum(gen)) # retorna a soma dos valores genotípcos por loco
}

# _____________________________________________________________________
#_ OK
#_ Função para regra da segregação
#_ Parâmetros:  pai e mãe = indvíduos sob análise (cruzando)
#______________________________________________________________________

segregacao <- function(pai, mae) { # argumentos da função
  filho <- numeric() # cria um vetor qualquer - armazena os valores
genotípicos do filho
  for(i in 1:length(pai)) { # 'laço' - passa a regra de segregação p/ cada
loco
    # se ambos pais são homozigotos dominantes (d), filho é dominante (d)
    # se um pai é dominante e o outro é heterozigoto (h) filho pode ser 'h'
ou 'd' 50% p/ cada
    # se ambos pais são heterozigoto segregação 1:2:1 'd', 'h', e 'r'
    # se um pai é dominante e o outro é recessivo filho é heterozigoto
    # se um pai é reccessivo e o outro é heterozigoto filho pode ser 'r' ou
'r' 50% p/ cada
    # se ambos pais são recessivos filho é recessivo
    if(pai[i] == 'd' & mae[i] == 'd') filho[i] <- 'd'
    if(pai[i] == 'd' & mae[i] == 'h' | pai[i] == 'h' & mae[i] == 'd'){
      u <- runif(1)
      if(u <= .5) filho[i] <- 'd' else filho[i] <- 'h'
    }
    if(pai[i] == 'd' & mae[i] == 'r' | pai[i] == 'r' & mae[i] == 'd'){
      filho[i] <- 'h'
    }
    if(pai[i] == 'h' & mae[i] == 'h'){
      u <- runif(1)
      if(u <= .25) filho[i] <- 'd' else
      if((u > .25) & (u <= .75)) filho[i] <- 'h' else
      filho[i] <- 'r'
    }
    if(pai[i] == 'h' & mae[i] == 'r' | pai[i] == 'r' & mae[i] == 'h'){
      u <- runif(1)
      if(u <= .5) filho[i] <- 'h' else filho[i] <- 'r'
    }
    if(pai[i] == 'r' & mae[i] == 'r') filho[i] <- 'r'
  }
  return(filho) # retorna a constituição genética do filho do cruzamento
}

# _____________________________________________________________________
#_ OK
#_ Função para fazer cruzamentos
#_ Parâmetros:    pai e mae = indvíduos, 'pai' e 'mãe'
#                     prole = número de indivíduos na progênie
#______________________________________________________________________

cruz<-function(pai, mae, prole){ # argumentos da função
  progenie <- matrix(NA, ncol = length(pai), nrow = prole) # cria matriz
qualquer [prole,g] - armazena a prole
  for(i in 1:prole) { #'laço' - cria prole filhos do cruzamento
    progenie[i,] <- segregacao(pai, mae)
  }
  return(progenie) # retorna a prole do cruzamento
}

>
> > # _____________________________________________________________________
> > #
> > #_ Função para fazer um dialelo
> > #_ Parâmetros:  pais = indivíduos selecionados na população anterior
> > #          população = população dos pais
> > #              prole = tamanho das progênies
> > #                 h2 = herdabilidade do caráter
> > #                gmd = grau médio de dominância
> > #______________________________________________________________________
> > dialelo <- function(pais, populacao, prole, h2, gmd) { # argumentos da
> > função
> >   combinacoes <- combinations(length(pais), 2, v = pais) # cria todas as
> > combinações híbridas
> >   progenies <- vector('list', length = nrow(combinacoes)) # cria a
> > estrutura
> > das progênies
> >   id <- cbind(rep(c(1:nrow(combinacoes)), each = prole),
> >               rep(combinacoes[,1], each = prole),
> >               rep(combinacoes[,2], each = prole)) # cria a estrutura de
> > identificação das progênies
> >   g <- ncol(populacao) - 5 # verifica o número de genes envolvidos
> >   for(i in 1:nrow(combinacoes)) { # 'laço' -  para executar todos
> > cruzamentos
> >     cruz.i <- cruz(populacao[combinacoes[i,1],4:(3 + g)],
> >                    populacao[combinacoes[i,2],4:(3 + g)],prole) # aplica
> a
> > função 'cruz'
> >     progenies[[i]] <- cruz.i # armazena a prole de cada cruzamento
> >   }
> >   dialelo <- as.data.frame(do.call(rbind, progenies)) # monta a planilha
> > com
> > o dialelo
> >   vg <- apply(dialelo, 1, soma.vg, gmd = gmd) # calcula os valores
> > genotípicos totais por indivíduo
> >   varg <- var(vg) # calcula a variância genética
> >   fen <- vg + rnorm(nrow(dialelo), mean = 0, sqrt(varg * (1 - h2) / h2))
> #
> > atribui o desvio fenotípico
> >   resp <- cbind(id, dialelo, vg, fen) # monta a planilha com os
> resultados
> > do dialelo
> >   names(resp) <- c('fami', 'pai', 'mae', 1:g, 'vg', 'fen') # atribui os
> > nomes as colunas da planilha
> >   return(resp) # retorna o dialelo
> > }
>
-------------- Próxima Parte ----------
Um anexo em HTML foi limpo...
URL: <http://listas.inf.ufpr.br/pipermail/r-br/attachments/20110321/ff870880/attachment.html>