[Stacomir-commits] r327 - in pkg/stacomir: . R inst/examples man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Mar 20 17:57:14 CET 2017
Author: briand
Date: 2017-03-20 17:57:13 +0100 (Mon, 20 Mar 2017)
New Revision: 327
Added:
pkg/stacomir/man/choice_c-BilanConditionEnv-method.Rd
pkg/stacomir/man/choice_c-RefStationMesure-method.Rd
pkg/stacomir/man/hbilanagedemer.Rd
pkg/stacomir/man/plot-BilanConditionEnv-missing-method.Rd
pkg/stacomir/man/supprime-BilanAgedemer-method.Rd
pkg/stacomir/po/
Removed:
pkg/stacomir/R/Bilan_stades_pigm.r
pkg/stacomir/R/Bilan_taille.r
pkg/stacomir/man/Bilan_stades_pigm-class.Rd
pkg/stacomir/man/Bilan_taille-class.Rd
pkg/stacomir/man/calcule-Bilan_taille-method.Rd
pkg/stacomir/man/charge-Bilan_stades_pigm-method.Rd
pkg/stacomir/man/charge-Bilan_taille-method.Rd
pkg/stacomir/man/connect-Bilan_stades_pigm-method.Rd
pkg/stacomir/man/connect-Bilan_taille-method.Rd
pkg/stacomir/man/fnstade.Rd
pkg/stacomir/man/fntablestade.Rd
pkg/stacomir/man/fun50.Rd
pkg/stacomir/man/funcalcbilan_stades_pigm.Rd
pkg/stacomir/man/fundist.Rd
pkg/stacomir/man/fungraphInteract_tail.Rd
pkg/stacomir/man/fungraphgg.Rd
pkg/stacomir/man/fungraphstades.Rd
pkg/stacomir/man/funphi.Rd
pkg/stacomir/man/funtableBilan_tail.Rd
pkg/stacomir/man/funtitle_bilan_stades_pigm.Rd
pkg/stacomir/man/hfungraphstades.Rd
pkg/stacomir/man/htodo.Rd
pkg/stacomir/man/interface_Bilan_stades_pigm.Rd
pkg/stacomir/man/surface.Rd
Modified:
pkg/stacomir/DESCRIPTION
pkg/stacomir/NAMESPACE
pkg/stacomir/R/BilanMigrationMult.r
pkg/stacomir/R/BilanOperation.r
pkg/stacomir/R/stacomi.r
pkg/stacomir/inst/examples/bilanMigration_Arzal.R
pkg/stacomir/man/BilanAgedemer-class.Rd
pkg/stacomir/man/BilanAnnuels-class.Rd
pkg/stacomir/man/BilanArgentee-class.Rd
pkg/stacomir/man/BilanConditionEnv-class.Rd
pkg/stacomir/man/BilanEspeces-class.Rd
pkg/stacomir/man/BilanFonctionnementDC-class.Rd
pkg/stacomir/man/BilanFonctionnementDF-class.Rd
pkg/stacomir/man/BilanMigration-class.Rd
pkg/stacomir/man/BilanMigrationConditionEnv-class.Rd
pkg/stacomir/man/BilanMigrationInterAnnuelle-class.Rd
pkg/stacomir/man/BilanMigrationMult-class.Rd
pkg/stacomir/man/Bilan_carlot-class.Rd
pkg/stacomir/man/Bilan_poids_moyen-class.Rd
pkg/stacomir/man/calcule-BilanAgedemer-method.Rd
pkg/stacomir/man/choice_c-BilanAgedemer-method.Rd
pkg/stacomir/man/connect-BilanConditionEnv-method.Rd
pkg/stacomir/man/hbilanConditionEnvgraph.Rd
pkg/stacomir/man/plot-Bilan_carlot-missing-method.Rd
pkg/stacomir/man/write_database-BilanAgedemer-method.Rd
pkg/stacomir/man/write_database-BilanMigration-method.Rd
Log:
removing two classes which will not be build in version 0.5.1 (choice made with Marion),
also correcting a bug for timoth?\195?\169e
Modified: pkg/stacomir/DESCRIPTION
===================================================================
--- pkg/stacomir/DESCRIPTION 2017-03-19 19:56:06 UTC (rev 326)
+++ pkg/stacomir/DESCRIPTION 2017-03-20 16:57:13 UTC (rev 327)
@@ -6,9 +6,9 @@
person("Marion", "Legrand", role = "aut", email="tableau-salt-loire at logrami.fr"),
person("Timothee", "Besse", role = "aut", email="tableau-ang-loire at logrami.fr"))
Description: Graphical outputs and treatment for a database of fishway
- monitoring. It is a part of the STACOMI open source project developed in France by the ONEMA
- institute to centralize data obtained by fishway monitoring. Version 0.5.1 is
- available in French English and Spanish.
+ monitoring. It is a part of the STACOMI open source project developed in France
+ by the ONEMA institute to centralize data obtained by fishway monitoring.
+ Version 0.5.1 is available in French English and Spanish.
License: GPL (>= 2)
Collate:
'create_generic.r'
@@ -45,8 +45,6 @@
'RefCoe.r'
'Bilan_poids_moyen.r'
'RefCheckBox.r'
- 'Bilan_stades_pigm.r'
- 'Bilan_taille.r'
'RefMsg.r'
'Refperiode.r'
'data.r'
Modified: pkg/stacomir/NAMESPACE
===================================================================
--- pkg/stacomir/NAMESPACE 2017-03-19 19:56:06 UTC (rev 326)
+++ pkg/stacomir/NAMESPACE 2017-03-20 16:57:13 UTC (rev 327)
@@ -43,8 +43,6 @@
exportClasses(BilanOperation)
exportClasses(Bilan_carlot)
exportClasses(Bilan_poids_moyen)
-exportClasses(Bilan_stades_pigm)
-exportClasses(Bilan_taille)
exportMethods(DateFin)
exportMethods(barplot)
exportMethods(calcule)
@@ -111,6 +109,7 @@
importFrom(lubridate,floor_date)
importFrom(lubridate,isoweek)
importFrom(lubridate,round_date)
+importFrom(lubridate,years)
importFrom(mgcv,gam)
importFrom(reshape2,dcast)
importFrom(reshape2,melt)
Modified: pkg/stacomir/R/BilanMigrationMult.r
===================================================================
--- pkg/stacomir/R/BilanMigrationMult.r 2017-03-19 19:56:06 UTC (rev 326)
+++ pkg/stacomir/R/BilanMigrationMult.r 2017-03-20 16:57:13 UTC (rev 327)
@@ -268,6 +268,7 @@
setMethod("connect",signature=signature("BilanMigrationMult"),definition=function(object,silent=FALSE){
# recuperation du BilanMigration
#bilanMigrationMult<-bmM
+
bilanMigrationMult<-object
# retrieve the argument of the function and passes it to bilanMigrationMult
# easier to debug
Modified: pkg/stacomir/R/BilanOperation.r
===================================================================
--- pkg/stacomir/R/BilanOperation.r 2017-03-19 19:56:06 UTC (rev 326)
+++ pkg/stacomir/R/BilanOperation.r 2017-03-20 16:57:13 UTC (rev 327)
@@ -44,7 +44,7 @@
#'
#' @author cedric.briand
setMethod("connect",signature=signature("BilanOperation"),definition=function(object,silent=FALSE) {
- # object=bilanOperation
+ # object<-bilanOperation
req<-new("RequeteODBCwheredate")
req at baseODBC<-get("baseODBC",envir=envir_stacomi)
lesdc<-object at dc@dc_selectionne
@@ -53,7 +53,7 @@
req at order_by="ORDER BY ope_dic_identifiant, ope_date_debut"
req at datedebut<-object at horodatedebut@horodate
#below to be consistet with BIlanMigrationMult
- req at datefin<-object at horodatefin@horodate+as.difftime("23:59:59")
+ req at datefin<-as.POSIXlt(object at horodatefin@horodate+as.difftime("23:59:59"))
req at select<-paste("SELECT * FROM ",get("sch",envir=envir_stacomi),"t_operation_ope ")
req at and=paste("AND ope_dic_identifiant in",stringr::str_c("(",stringr::str_c(lesdc,collapse=","),")"))
req<-stacomirtools::connect(req) # appel de la methode connect de l'object ODBCWHEREDATE
Deleted: pkg/stacomir/R/Bilan_stades_pigm.r
===================================================================
--- pkg/stacomir/R/Bilan_stades_pigm.r 2017-03-19 19:56:06 UTC (rev 326)
+++ pkg/stacomir/R/Bilan_stades_pigm.r 2017-03-20 16:57:13 UTC (rev 327)
@@ -1,902 +0,0 @@
-#' Bilan class for pigment stage structure analysis (glass eel)
-#'
-#' The pigment stages analysis has been developed to allow to analyze the
-#' change in pigment stage structure for glass eel (Anguilla anguilla). The
-#' class uses the parameters calibrated by Briand et al. , 2005 to
-#' backcalculate the probable date when the glass eels arrived in the estuary
-#' (i.e. at a fully transparent stage VB. The evolution of pigment stages is
-#' modeled with gamma functions which use a pigment time calculated from daily
-#' temperatures and salinities. The temperatures has a major influence on the
-#' glass eel pigment stage evolution.
-#' @slot data (please_describe)
-#' @slot datatempsal (please_describe)
-#' @slot tablestades (please_describe)
-#' @slot phi (please_describe)
-#' @slot dates (please_describe)
-#' @slot Vparm default values for parm from Briand 2005 \code{list(pigment_stage=list("p1"=0.267,"p2"=0.835,"p3"=1.560,"p4"=3.682),
-#' pigmentation=list("teta"=30,"sigma"=40,"sigma2"=-5,"p5"=4.566,
-#' "p6"=8.141,"p7"=0.071,"p8"=0.426))}
-#' @slot dc (please_describe)
-#' @slot stationMesure (please_describe)
-#' @slot horodate (please_describe)
-#' @slot datedebut (please_describe)
-#' @slot datefin (please_describe)
-#' @slot lmax (please_describe)
-#' @slot options (please_describe)
-#' @slot salinite (please_describe)
-#' @slot labelretro (please_describe)
-#' @slot labelgraphstades (please_describe)
-#' @slot effectifs (please_describe)
-#' @include RefCheckBox.r
-#' @include ReftextBox.r
-#' @note This class is displayed by interface_bilan_stades_pigm, The class uses
-#' temperature (from an abiotic measure station) and mean salinity to calculate
-#' the change towards one stage
-#' @section Objects from the Class: Objects can be created by calls of the form
-#' \code{new("Bilan_stades_pigm", ...)}.
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-#' @family Bilan Objects
-#' @keywords classes
-#' @references BRIAND C., FATIN D., CICCOTTI E. and LAMBERT P., 2005. A
-#' stage-structured model to predict the effect of temperature and salinity on
-#' glass eel Anguilla anguilla pigmentation development. J Fish Biol, 67,
-#' 995-1009.
-#' \url{http://www3.interscience.wiley.com/journal/118686679/abstract}
-#' \url{http://www.eptb-vilaine.fr/site/index.php/les-migrateurs/documents/publications-scientifiques/46-publications-migrateurs/60-dynamique-de-population-et-de-migration-des-civelles-en-estuaire-de-vilaine}
-#' @examples
-#' #' showClass("Bilan_stades_pigm")
-#' @export
-setClass(Class="Bilan_stades_pigm",
- representation= representation(data="data.frame",
- datatempsal="data.frame",
- tablestades="data.frame",
- phi="list",
- dates="POSIXt",
- Vparm="list",
- dc="RefDC",
- stationMesure="RefStationMesure",
- horodate="RefHorodate",
- datedebut="POSIXlt",
- datefin="POSIXlt",
- lmax="RefChoix",
- options="RefCheckBox",
- salinite="RefTextBox",
- labelretro="character",
- labelgraphstades="character",
- effectifs="numeric"),
- prototype=prototype(data=data.frame(),
- datatempsal=data.frame(),
- phi=data.frame(),
- Vparm=list(pigment_stage=list("p1"=0.267,"p2"=0.835,"p3"=1.560,"p4"=3.682),
- pigmentation=list("teta"=30,"sigma"=40,"sigma2"=-5,"p5"=4.566,
- "p6"=8.141,"p7"=0.071,"p8"=0.426)),
- dc=new("RefDC"),
- stationMesure=new("RefStationMesure"),
- horodate=new("RefHorodate"),
- lmax=new("RefChoix"),
- options=new("RefCheckBox"),
- salinite=new("RefTextBox")
- ))
-#
-#' connect method for Bilan_stades_pigm
-#'
-#'
-#' @note will try to get data for the temperature (refstation) only if retrocalcul is checked
-#' by default it is not when lanching
-#' @param object An object of class \link{Bilan_stades_pigm-class}
-#' @return An object of class Bilan_stades_pigm
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-setMethod("connect",signature=signature("Bilan_stades_pigm"),definition=function(object) {
- # pour debug object<-new("Bilan_stades_pigm")
- # chargement du tableau des stades pigmentaires
- requete=new("RequeteODBCwheredate")
- requete at baseODBC=get("baseODBC",envir=envir_stacomi)
- requete at select= paste("SELECT * FROM ",get("sch",envir=envir_stacomi),"vue_lot_ope_car",sep="")
- requete at colonnedebut="ope_date_debut"
- requete at colonnefin="ope_date_fin"
- requete at order_by="ORDER BY ope_date_debut"
- requete at datedebut=strptime(object at datedebut,format="%Y-%m-%d")
- requete at datefin=strptime(object at datefin,format="%Y-%m-%d")
- requete at and=paste(" AND ope_dic_identifiant=",object at dc@dc_selectionne,
- " AND lot_tax_code= '2038'",
- " AND lot_std_code= 'CIV'",
- " AND car_par_code='1791'",sep="")
- requete<-stacomirtools::connect(requete) # appel de la methode stacomirtools::connect de l'object ODBCWHEREDATE
- funout(gettext("Pigmentation stages loading query completed",domain="R-stacomiR"))
- object at data<-stacomirtools::killfactor(requete at query)
- if (nrow (requete at query)>0) {
-
- stades<-stacomirtools::killfactor(requete at query)
- choicepere=c("lotpere","date")
- funout(paste("Attention il peut y avoir plusieurs lots a la meme date, et certains stades sont fait sans lotpere (ex taille-poids-stade)\n"))
- choicepere=select.list(choicepere,preselect="date",multiple=FALSE,
- title=paste("Regroupement des ech par lot pere ou par date ?"))
- lst<-fntablestade(stades,choicepere)
- dates<-lst[["dates"]]
- tablestades<-lst[["tablestades"]]
- # transformation en pourcentages
- effectifs=rowSums(tablestades)
- object at effectifs<-effectifs
- tablestades=tablestades/effectifs
- object at tablestades<-tablestades
- object at dates<-dates
- } else funout(gettext("No data for pigmentation stages",domain="R-stacomiR"),arret=TRUE)
- if (object at options@checked[2]){
- # chargement du tableau des temperatures
- requete at datedebut=as.POSIXlt(strptime(object at datedebut,format="%Y-%m-%d")-5184000) # 60 jours avant
- requete at colonnedebut="env_date_debut"
- requete at colonnefin="env_date_fin"
- requete at select=paste("SELECT",
- " env_date_debut,",
- " env_date_fin,",
- " env_methode_obtention,",
- " val_libelle as env_val_identifiant,",
- " env_valeur_quantitatif,",
- " env_stm_identifiant",
- " FROM ",get("sch",envir=envir_stacomi),"tj_conditionenvironnementale_env",
- " LEFT JOIN ref.tr_valeurparametrequalitatif_val on env_val_identifiant=val_identifiant",sep="")
- requete at order_by<-"ORDER BY env_stm_identifiant, env_date_debut"
- tmp<-vector_to_listsql(object at stationMesure@data$stm_identifiant)
- requete at and=paste(" AND env_stm_identifiant IN ",tmp )
- requete<-stacomirtools::connect(requete)
- funout(gettext("Environmental conditions loading query completed",domain="R-stacomiR"))
- if (nrow (requete at query)>0) {
- if (unique(requete at query$env_stm_identifiant)>1) funout(gettext("You chose several stations",domain="R-stacomiR"), arret=TRUE)
- object at datatempsal<-stacomirtools::killfactor(requete at query)[,c("env_date_debut","env_valeur_quantitatif")]
- object at datatempsal$salinite=as.numeric(object at salinite@label)
- colnames(object at datatempsal)<-c("date","temperature","salinite")
- } else {
- funout(gettext("no temperature data, you won't be able to retrocalculate arrival dates",domain="R-stacomiR"))
- }
- }
- return(object)
- })
-
-#' function calculating a table with pigment stages VB to VIA3 from lines retreived from the database
-#' containing individual characteristic of glass eel#'
-#' this function is called from within the charge method it was separated from the charge method
-#' as it it convenient to use elsewhere
-#' @usage fntablestade(stades,choicepere="lotpere")
-#' @param stades a data frame containing stage values
-#' @param choicepere either "date" or "lot_pere" the first will group pigment stage by date,
-#' the second will allow to keep separate lines when several samples have been collected a given day
-#' @return a list with tablestades atable with numbers per stage for a given date or lotpere (sample), and date
-#' @author Cedric Briand \\email{cedric.briand"at"eptb-vilaine.fr}
-#' @seealso \code{\linkS4class{Bilan_stades_pigm}}
-fntablestade<-function(stades,choicepere="lotpere"){
- if (choicepere=="lotpere"){
- tablestades=stats::ftable(stats::xtabs(stades$lot_effectif ~ stades$lot_pere +
- + stades$val_libelle))
- tablestades<-tab2df(tablestades)# fonction developpee dans utilitaires
- # recuperation des dates correspondant aux numeros d'operation
- # le format de ftable n'est pas celui d'un data frame
- indx<-match(sort(unique(stades$lot_pere)),stades$lot_pere)
- dates<-stades[indx,"ope_date_debut"]
- # creation d'une matrice qui somme les stades VA+VB et les stades VIA3 et VIA4
- if ("VA"%in%dimnames(tablestades)){
- tablestades$VB=tablestades$VB+tablestades$VA
- tablestades=tablestades[,-c("VA")]
- }
- if ("VIA4"%in%dimnames(tablestades)){
- tablestades$VIA3=tablestades$VIA3+tablestades$VIA4
- tablestades=tablestades[,-"VIA4"]
- }
- tablestades=tablestades[order(dates),] # on reclasse par dates
- print(cbind(tablestades, "lot_pere"=sort(unique(stades$lot_pere))[order(dates)]))
- dates=sort(dates)
- # je colle les numeros de lots peres en les reordonnant en fonction du classt des dates
- } else if (choicepere=="date"){
- tablestades=stats::ftable(stats::xtabs(stades$lot_effectif ~ stades$ope_date_debut +
- + stades$val_libelle))
- print(stats::xtabs(stades$lot_effectif ~ stades$ope_date_debut +
- + stades$val_libelle))
- dates<-sort(unique(stades$ope_date_debut))
- tablestades<-tab2df(tablestades) # fonction developpee dans utilitaires
- if ("VA"%in%dimnames(tablestades)[[2]]){
- tablestades$VB=tablestades$VB+tablestades$VA
- tablestades=tablestades[,-c("VA")]
- }
- if ("VIA4"%in%dimnames(tablestades)[[2]]){
- tablestades$VIA3=tablestades$VIA3+tablestades$VIA4
- tablestades=tablestades[,-match("VIA4",dimnames(tablestades)[[2]])]
- }
- #dimnames(tablestades) <- list(as.character(dates),
- # c("VB","VIA0","VIA1","VIA2","VIA3"))
- }
-
- return(list("tablestades"=tablestades,"dates"=dates))
-}
-#' Charge method for BilanStadePigm
-#'
-#' method used by the graphical interface to build object from values
-#' stored in envir_stacomi
-#' @param object An object of class \code{\link{Bilan_stades_pigm-class}}
-#' @param h A handler
-#' @return Bilan_stades_pigm with slots filled with user choice
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-setMethod("charge",signature=signature("Bilan_stades_pigm"),definition=function(object,h) {
- if (exists("refDC",envir_stacomi)) {
- object at dc<-get("refDC",envir_stacomi)
- } else {
- funout(gettext("You need to choose a counting device, clic on validate",domain="R-stacomiR"),arret=TRUE)
- }
- # rem pas tres satisfaisant car ce nom est choisi dans l'interface
- if (exists("bilan_stades_pigm_date_debut",envir_stacomi)) {
- object at datedebut<-get("bilan_stades_pigm_date_debut",envir_stacomi)@horodate
- } else {
- funout(gettext("You need to choose the starting date\n",domain="R-stacomiR"),arret=TRUE)
- }
- if (exists("bilan_stades_pigm_date_fin",envir_stacomi)) {
- object at datefin<-get("bilan_stades_pigm_date_fin",envir_stacomi)@horodate
- } else {
- funout(gettext("You need to choose the ending date\n",domain="R-stacomiR"),arret=TRUE)
- }
- if (exists("refCheckBox",envir_stacomi)) {
- object at options<-get("refCheckBox",envir_stacomi)
- } else {
- # rien de toutes facons les choice par defaut sont copies dans envir_stacomi
- }
- if (exists("refchoice",envir_stacomi)) {
- object at lmax<-get("refchoice",envir_stacomi)
- } else {
- # l'assignation d'un object liste choice remplace la liste des valeurs possibles
- # par la valeur choisie (pour l'instant "0.8")
- object at lmax@listechoice<-"0.8"
- }
- if (exists("refTextBox",envir_stacomi)) {
- object at salinite<-get("refTextBox",envir_stacomi)
- } else {
- # rien de toutes faeons les choice par defaut sont copies dans envir_stacomi
- }
- if (object at options@checked[2]){
- if (exists("refStationMesure",envir_stacomi)) {
- object at stationMesure<-get("refStationMesure",envir_stacomi)
- } else {
- funout(gettext("You need to choose a monitoring station, clic on validate\n",domain="R-stacomiR"),arret=TRUE)
- }
- }
- object<-connect(object)
- return(object)
- })
-
-
-#' plots polygons
-#'
-#'
-#' @param xmat a matrix of x values of the polygons
-#' @param ymat a matrix where the number of rows is of the same length as xmat
-#' @param ordre the order in which the polygons will be drawn
-#' @param couleur a color vector
-#' @param \dots additional arguments passed to the function
-#' @return Bilan_stades_pigm with slots filled with user choice
-#' @author Laurent Beaulaton \email{laurent.beaulaton"at"onema.fr}
-surface=function(xmat,ymat,ordre=1:dim(ymat)[2],couleur=1:dim(ymat)[2],...) {
- x=c(xmat,rev(xmat))
- nbcol=dim(ymat)[2]
- nblig=dim(ymat)[1]
- total=numeric(nblig)
- for (i in 1:nbcol) total=total+ymat[,i]
- nouvmat=matrix(nrow=nblig*2,ncol=nbcol)
- nouvmat[1:nblig,1]=ymat[,ordre[1]]
- nouvmat[(nblig+1):(nblig*2),1]=0
- for (i in 2:nbcol) {
- nouvmat[1:nblig,i]=ymat[,ordre[i]]+nouvmat[1:nblig,i-1]
- nouvmat[(nblig+1):(nblig*2),i]=rev(nouvmat[1:nblig,i-1])
- }
- plot(x[1:nblig],total,type="l",ylim=c(0,max(total)*1.1),...)
- for (i in 1:nbcol) polygon(x,nouvmat[,i],col=couleur[i])
-}
-
-
-
-#' Function to calculate pigmentation times.
-#'
-#'
-#' @param parm parameters of the model
-#' @param datatempsal data.frame containing temperatures and salinities
-#' @return list("dates"=time.sequence,"phi_jour"=phi_jour)
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-funphi<-function(parm,datatempsal){
- temperature=datatempsal$temperature
- salinity=datatempsal$salinite
- time.sequence=as.character(datatempsal$date)
- phi_T=pbeta(temperature/parm$teta,parm$p5,parm$p6) #(time.sequence,nb_area)
- phi_S=1-pbeta((salinity-parm$sigma2)/(parm$sigma-parm$sigma2),parm$p7,parm$p8)
- phi_jour=phi_T*phi_S
- return(list("dates"=time.sequence,"phi_jour"=phi_jour))
-}
-
-
-
-
-
-
-
-#' function drawing polygon from gamma law describing pigmentation change in
-#' glass eel
-#'
-#' function calculating from the gamma law the coordinates x and y allowing to
-#' draw a polygon, the function fnstade may be used to draw a polygon(neg=TRUE)
-#' or simply return the values from gamma function of each stage
-#'
-#'
-#' @param par1 Parameter describing the gamma law for the first stage
-#' @param par2 Parameter of the gamma law for the second stage
-#' @param phicum cumulated pigmentation times for test : phicum=seq(0,20,
-#' length.out=100)
-#' @param phidates Dates
-#' @param VB If TRUE, then calculation for first stage VB which differs from
-#' the others
-#' @param neg If FALSE then calculation of stages according to the pigmentation
-#' time
-#' @param lmax Scale parameter for the graphical function, lmax=0 allows to
-#' draw the real values of abundances per stage along time, lmax=1 or 0.8 will
-#' draw all stages at the same scale
-#' @return A list with x and y
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-#' @seealso \code{\linkS4class{Bilan_stades_pigm}}
-#' @references BRIAND C., FATIN D., CICCOTTI E. and LAMBERT P., 2005. A
-#' stage-structured model to predict the effect of temperature and salinity on
-#' glass eel Anguilla anguilla pigmentation development. J Fish Biol, 67,
-#' 995-1009.
-#' \url{http://www3.interscience.wiley.com/journal/118686679/abstract}
-#' \url{http://www.eptb-vilaine.fr/site/index.php/les-migrateurs/documents/publications-scientifiques/46-publications-migrateurs/60-dynamique-de-population-et-de-migration-des-civelles-en-estuaire-de-vilaine}
-fnstade<-function(par1, par2=NULL,phicum,phidates,VB=FALSE,neg=TRUE,lmax=1){
- if (neg){
- phidates=as.numeric(as.POSIXct(strptime(phidates,format="%Y-%m-%d")))
- }
- sequ=phicum
- if (VB){ #VB
- dist1<-stats::pgamma(sequ,par1)
- dist=1-dist1
- } else if (is.null(par2)) { # VIA3
- dist1<-stats::pgamma(sequ,par1)
- dist=dist1
- } else if (!is.null(par2)){ # VIA0...VIA3
- dist1<-stats::pgamma(sequ,par1)
- dist2<- stats::pgamma(sequ,par2)
- dist=dist1-dist2
- }
- if (lmax>0){
- dist=lmax*dist/max(dist)
- }
- if (neg){
- x=c(rev(phidates),phidates)
- y=c(rev(dist),-dist)
- } else {
- x=sequ
- y=dist
- }
- return(list("x"=x,"y"=y))
-}
-
-
-
-
-
-
-
-#' used by \code{fundist} function, returns the value of obj where more than 50
-#' percent of the distribution objc is reached
-#'
-#' Allows to point the middle of the gamma distribution for each stage
-#'
-#'
-#' @param obj The pigment time scale
-#' @param objc Cumulated gamma curve
-#' @return d50 The center of the distribution for the different stages
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-#' @seealso \code{\linkS4class{Bilan_stades_pigm}}
-fun50<-function(obj,objc){
- d50<-obj[objc>0.5][1]
- return(d50)
-}
-
-
-
-
-
-
-#' fundist =function to calculate the median of the distribution of pigment
-#' stages
-#'
-#' see code
-#'
-#'
-#' @param Vparm Parameters for the gamma functions describing pigment stages
-#' @param phicum Cumulated pigmentation time
-#' @param graph Logical, to see the curves type graph = TRUE
-#' @param lmax Scale parameter of the graphical function see \link{fnstade}
-#' @note pigment stage functions are not standard statistical distribution,
-#' calculating where 50\% of the distribution lies is done with fun50 this
-#' function uses \link{fnstade} to calculate the values of pigment times on a
-#' regular scale (phicum)
-#' @seealso \code{\linkS4class{Bilan_stades_pigm}}
-#' @examples
-#' \dontrun{
-#' Vparm<-list()
-#' #below param for briand et al.,2005 pigmentation function in glass eel
-#' #parameters for gamma functions describing changes from stage to stage
-#' Vparm$pigment_stage$p1<-0.267
-#' Vparm$pigment_stage$p2<-0.835
-#' Vparm$pigment_stage$p3<-1.56
-#' Vparm$pigment_stage$p4<-3.682
-#' Vparm$pigmentation$teta<- 30 # bounding parameters for beta function
-#' Vparm$pigmentation$sigma<-40 # bounding parameters for beta function
-#' Vparm$pigmentation$sigma2<--5 # bounding parameters for beta function
-#' Vparm$pigmentation$p5<- 4.566 # param for beta function
-#' Vparm$pigmentation$p6<-8.141
-#' Vparm$pigmentation$p7<-0.071 # param for beta function
-#' Vparm$pigmentation$p8<-0.426
-#' fundist(Vparm,seq(0,10, length.out=10000),graph=FALSE,lmax=1)
-#' fundist(Vparm,seq(0,10, length.out=10000),graph=TRUE,lmax=1)
-#' fundist(Vparm,seq(0,10, length.out=10000),graph=TRUE,lmax=0)
-#' plot(seq(0,10, length.out=10000),pgamma(seq(0,10, length.out=10000),
-#' Vparm$pigment_stage[[1]]),col="pink")
-#' points(seq(0,10, length.out=10000),pgamma(seq(0,10, length.out=10000),
-#' Vparm$pigment_stage[[2]]),col="firebrick")
-#' }
-fundist=function(Vparm, phicum,graph=TRUE,lmax=1){
- VB=fnstade(par1=Vparm$pigment_stage[[1]],VB=TRUE,phicum=phicum,neg=FALSE,lmax=lmax)
- VBc=cumsum(VB$y)/sum(VB$y) # surface
- VIA0= fnstade(par1=Vparm$pigment_stage[[1]],par2=Vparm$pigment_stage[[2]],VB=FALSE,phicum=phicum,neg=FALSE,lmax=lmax)
- VIA0c=cumsum(VIA0$y)/sum(VIA0$y) # surface
- VIA1= fnstade(par1=Vparm$pigment_stage[[2]],par2=Vparm$pigment_stage[[3]],VB=FALSE,phicum=phicum,neg=FALSE,lmax=lmax)
- VIA1c=cumsum(VIA1$y)/sum(VIA1$y) # surface
- VIA2= fnstade(par1=Vparm$pigment_stage[[3]],par2=Vparm$pigment_stage[[4]],VB=FALSE,phicum=phicum,neg=FALSE,lmax=lmax)
- VIA2c=cumsum(VIA2$y)/sum(VIA2$y) # surface
- VIA3= fnstade(par1=Vparm$pigment_stage[[4]],VB=FALSE,phicum=phicum,neg=FALSE,lmax=lmax)
- VIA3c=cumsum(VIA3$y)/sum(VIA3$y) # surface
- if(graph){
- dev.new()
- matplot(VB$x,cbind(VB$y,VIA0$y,VIA1$y,VIA2$y,VIA3$y))
-
- dev.new()
- matplot(VB$x,cbind(VBc,VIA0c,VIA1c,VIA2c,VIA3c))
- }
- #traitement a part de VB
- # raison = ca marche pas sinon
- # dans le modele VB = 1-p(VIA0) proba de ne pas etre au stade suivant ?
- out=c( VB$x[VB$x>Vparm$pigment_stage[[1]]][1],
- fun50(VIA0$x,VIA0c),
- fun50(VIA1$x,VIA1c),
- fun50(VIA2$x,VIA2c),
- fun50(VIA3$x,VIA3c))
- #list("VB"=VB,"VBc"=VBc,
-# "VIA0"=VIA0,"VIA0c"=VIA0c,
-# "VIA1"=VIA1, "VIA1c"=VIA1c,
-# "VIA2"=VIA2, "VIA2c"=VIA2c,
-# "VIA3"= VIA3, "VIA3c"=VIA3c)
- return(out)
-}
-
-
-
-
-
-
-
-#' main launching function for class Bilan_stades_pigm
-#'
-#' Function with handler which calls charge (and thus connect) and calculates
-#' the title
-#'
-#'
-#' @param h A handler
-#' @param ... additional arguments
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-funcalcbilan_stades_pigm<-function(h,...){
- bilan_stades_pigm<-charge(bilan_stades_pigm)
- if (nrow(bilan_stades_pigm at datatempsal)>0){
- bilan_stades_pigm at phi<-funphi(parm=bilan_stades_pigm at Vparm$pigmentation,bilan_stades_pigm at datatempsal)
- }
- funout(gettext("Loading data from database",domain="R-stacomiR"))
- dates<-bilan_stades_pigm at dates
- bilan_stades_pigm at labelgraphstades<-gettextf("Pigmentation stages %s and incoming dates in estuary",
- if(strftime(as.POSIXlt(dates[1]),"%Y")==
- strftime(as.POSIXlt(dates[length(dates)]),"%Y")) {
- strftime(as.POSIXlt(dates[1]),"%Y")} else { paste(
- strftime(as.POSIXlt(dates[1]),"%Y"),"-",
- strftime(as.POSIXlt(dates[length(dates)]),"%Y"))},domain="R-stacomiR")
- bilan_stades_pigm at labelretro=gettext("incoming dates in estuary",domain="R-stacomiR")
- enabled(toolbarlist[["SetTitle"]])<-TRUE
- enabled(toolbarlist[["Graph"]])<-TRUE
- enabled(toolbarlist[["Graphgg"]])<-TRUE
- assign("bilan_stades_pigm",bilan_stades_pigm,envir_stacomi)
-}
-
-#' handler function for fungraphstades
-#' @param h handler
-#' @param ... additional parameters
-hfungraphstades=function(h,...){
- bilan_stades_pigm<-get("bilan_stades_pigm",envir_stacomi)
- fungraphstades(
- tablestades=bilan_stades_pigm at tablestades,
- retrocalcul=bilan_stades_pigm at options@checked[2],
- datatempsal=bilan_stades_pigm at datatempsal,
- points=bilan_stades_pigm at options@checked[3],
- nb=bilan_stades_pigm at options@checked[4],
- graphstades=bilan_stades_pigm at options@checked[1],
- lmax=as.numeric(bilan_stades_pigm at lmax@listechoice),
- labelretro=bilan_stades_pigm at labelretro,
- labelgraphstades=bilan_stades_pigm at labelgraphstades,
- phi=bilan_stades_pigm at phi, # tableau des temps pigmentaires et des dates format "%d/%m/%Y"
- maxVIA3=10, # valeur maximale autorisee pour VIA3
- dates=bilan_stades_pigm at dates,
- Vparm=bilan_stades_pigm at Vparm,
- effectifs=bilan_stades_pigm at effectifs # pour le label si nb =TRUE
- )
-}
-
-
-
-
-
-
-
-#' Main function for class Bilan_stades_pigm allowing to calculate and then
-#' draw the graphs
-#'
-#' see R code for details
-#'
-#'
-#' @param tablestades A data frame with stages VB VIA0 VIA1 VIA2 VIA3
-#' @param retrocalcul Logical TRUE or FALSE, do you want to retrocalculate when
-#' the glass eel have arrived in the estuary, in this case provide datatempsal,
-#' data for temperature and salinity
-#' @param datatempsal to draw the graph of recalculated dates of arrival,
-#' provide this data.frame, format graphique des time.sequences en estuaire, format
-#' [,c("date","temperature","salinite")]
-#' @param points logical, do you want to draw the points on the cumulative
-#' pigmentation graph
-#' @param nb Do you want to write number in sample in the pigmentation stage
-#' graph
-#' @param graphstades Do you want to draw the graph of cumulated stage
-#' @param lmax parameter for retrocalcul graph, see \link{fnstade} scale
-#' parameter for the graphical function, use 0.8 to avoid overlapping of the
-#' polygons from several samples or dates
-#' @param labelretro label for retrocalcul graph, can be changed in the
-#' graphical interface
-#' @param labelgraphstades label for stage graph, can be changed in the
-#' graphical interface
-#' @param phi table of pigmentation time and dates format "\%d/\%m/\%Y"
-#' @param maxVIA3 10, maximum value of pigment time for VIA3, limits the
-#' duration of this longer stage
-#' @param dates dates
-#' @param Vparm parameters for pigment stage function
-#' @param effectifs logical : do you want to display numbers on the graph
-#' @author Cedric Briand \email{cedric.briand"at"eptb-vilaine.fr}
-fungraphstades<-function(
- tablestades,
- retrocalcul=TRUE, # deuxieme partie du graphe dans ce cas fournir datatempsal
- datatempsal, # graphique des time.sequences en estuaire, format [,c("date","temperature","salinite")]
- points=TRUE, # affichage des points
- nb=TRUE, # affichage des effectifs
- graphstades=TRUE, # affichage du graphe pour evol stades
- lmax=1, # largeur ex:0.8 pour eviter un chevauchement des graphes
- labelretro, # titre du graphe retro si celui-ci est trace tout seul
- labelgraphstades,
- phi, # tableau des temps pigmentaires et des dates format "%d/%m/%Y"
- maxVIA3=10, # valeur maximale autorisee pour VIA3
- dates,
- Vparm,
- effectifs # pour le label si nb =TRUE
-){
- VB =as.vector(tablestades[,1]) #vector of stades VB+VIA0 observed data
- VIA0=as.vector(tablestades[,2]+tablestades[,1])
- VIA1=as.vector(tablestades[,3]+tablestades[,2]+tablestades[,1])
- VIA2=as.vector(tablestades[,4]+tablestades[,3]+tablestades[,2]+tablestades[,1])
- VIA3=as.vector(tablestades[,5]+tablestades[,4]+tablestades[,3]+tablestades[,2]+tablestades[,1])
- stadescum=cbind(VIA0,VIA1,VIA2,VIA3)
-
- if (retrocalcul & graphstades) {
- vec<-c(rep(2,3),rep(1,2))
- mat <- matrix(vec,length(vec),1)
- } else { # un seul graphe
- mat <- matrix(1,1,1)
- } # on ne trace pas le graphe suivant
- layout(mat)
- ##############################################################################################
- if (retrocalcul){
- # on verifie les donnees environnementales
- na.fail(phi) #Pas de donnees manquantes
- # si les vecteur phi ne va pas jusqu'au dernier stade, on tronque le tableau
- # et on envoie un warning
- strdates=strftime(as.POSIXlt(dates),"%Y-%m-%d")
- curv=list()
- phist=fundist(Vparm,phicum=seq(0,10, length.out=1000),graph=FALSE)
-
-# creation d'une matrice (tps) ayant en ligne chaque donnee de stade et
-# en colonne phist (temps pigmentaires moyens standard des distributions pour chaque stade)
-# et en derniere colonne la moyenne ponderee par les stades i.e; le temps pigmentaire moyen de
-# l'echantillon
- tps =c(phist,"moy"=sum(tablestades[1,]*phist))
- for (j in 2:nrow(tablestades)){
- tps=rbind(tps, c(unlist(phist),
- sum(tablestades[j,]*phist)))
- }
- dimnames(tps)=list(strdates,c("VB","VIA0",
- "VIA1","VIA2","VIA3","moy"))
- cherchenuls=tablestades
- cherchenuls[cherchenuls>0]=1
- cherchenuls=cbind(cherchenuls,rep(1,length(dates)))
- # cherchenul cherche les stades nuls (sans valeur) pour ne pas renvoyer de warning
- # correpondant e un depassement du temps pigmentaire :
- # ex : les temps physiologiques remontent un mois avant, les stades VIA3
- # auraient necessite 1 mois et demi mais ils sont absents du jeu de donnees
-
- #vecteur des temps pigmentaires moyens de chaque stade
- for (j in 1:nrow(tablestades)){
- # On part de la date observee 1:match(rownames(tps)[j],phi$dates)])
- # et on calcule le cumul du vecteur inverse
- phicum=cumsum(rev(phi$phi_jour[1:match(strdates[j],phi$dates)]))
- phicum=phicum[phicum<maxVIA3]
- # pour des raisons graphiques, je m'arrete e un temps pigmentaire de maxVIA3
- # au dele on sait que c'est 100% de VIA3
- # il faudrait avoir modelise jusqu'au stade VIA4
- # on va chercher la date correspondante
- phidates=rev(phi$dates[1:match(strdates[j],phi$dates)])[1:length(phicum)]
- # structures des stades en x et y calcules e partir de la fonction gamma
- # x = les phicum (croissant en remontant dans le temps
- # y = la distribution dist/max(dist) entre zero et 1
- #
- curv[[strdates[j]]]$VB =fnstade(par1=Vparm$pigment_stage[[1]],VB=TRUE,phicum=phicum,phidates=phidates,neg=TRUE,lmax=lmax)
- curv[[strdates[j]]]$VB$y=tablestades[j,1]*curv[[strdates[j]]]$VB$y
- curv[[strdates[j]]]$VIA0= fnstade(par1=Vparm$pigment_stage[[1]],
- par2=Vparm$pigment_stage[[2]],VB=FALSE,phicum=phicum,phidates=phidates,neg=TRUE,lmax=lmax)
- curv[[strdates[j]]]$VIA0$y=tablestades[j,2]*curv[[strdates[j]]]$VIA0$y
- curv[[strdates[j]]]$VIA1= fnstade(par1=Vparm$pigment_stage[[2]],
- par2=Vparm$pigment_stage[[3]],VB=FALSE,phicum=phicum,phidates=phidates,neg=TRUE,lmax=lmax)
- curv[[strdates[j]]]$VIA1$y=tablestades[j,3]*curv[[strdates[j]]]$VIA1$y
- curv[[strdates[j]]]$VIA2= fnstade(par1=Vparm$pigment_stage[[3]],
- par2=Vparm$pigment_stage[[4]],VB=FALSE,phicum=phicum,phidates=phidates,neg=TRUE,lmax=lmax)
- curv[[strdates[j]]]$VIA2$y=tablestades[j,4]*curv[[strdates[j]]]$VIA2$y
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/stacomir -r 327
More information about the Stacomir-commits
mailing list