R/cdtQC_Homogeneity_leftCmd.R

Defines functions testHomogeneityPanelCmd

testHomogeneityPanelCmd <- function(){
    listOpenFiles <- openFile_ttkcomboList()
    if(WindowsOS()){
        largeur0 <- 23
        largeur1 <- 31
        largeur2 <- 33
        largeur3 <- 22
        largeur4 <- 18
        largeur5 <- 17
        largeur6 <- 21
        largeur7 <- 7
        largeur8 <- 11
        largeur9 <- 17
        largeur10 <- 17
    }else{
        largeur0 <- 23
        largeur1 <- 31
        largeur2 <- 33
        largeur3 <- 25
        largeur4 <- 24
        largeur5 <- 19
        largeur6 <- 23
        largeur7 <- 7
        largeur8 <- 12
        largeur9 <- 19
        largeur10 <- 18
    }

    GeneralParameters <- list(intstep = "daily", infile = "", outdir = "",
                              stats = list(mthd = 'SNHT', crop = FALSE, h = 0.025, kmax = 10,
                                           conf.lev = 95, min.len = 24, min.year = 5, min.frac = 0.5),
                              series = list(use = FALSE, use.climato = TRUE, diff.ratio = 1, weight = 1,
                                            voisin = list(min = 4, max = 8, dist = 60, elv = 800, rho = 0.3),
                                            elv = list(use = FALSE, dem = TRUE, file = ""),
                                            user = list(refs = FALSE, file = "")
                                          ),
                              adj = list(min.mon = 32, min.dek = 32, min.dyp = 32,
                                         seg.mon = 0, seg.dek = 0, seg.dyp = 0),
                              aggr = list(aggr.fun = "mean", opr.fun = ">=", opr.thres = 0,
                                          min.frac = list(unique = TRUE, all = 0.95,
                                                          month = rep(0.95, 12))),
                              plotSeries = 'testSeries', adjSeries = 'none'
                            )

    MOIS <- format(ISOdate(2014, 1:12, 1), "%B")

    xml.dlg <- file.path(.cdtDir$dirLocal, "languages", "cdtQC_Homogeneity_leftCmd.xml")
    lang.dlg <- cdtLanguageParse(xml.dlg, .cdtData$Config$lang.iso)
    .cdtData$EnvData$message <- lang.dlg[['message']]

    ###################

    .cdtEnv$tcl$main$cmd.frame <- tkframe(.cdtEnv$tcl$main$panel.left)

    tknote.cmd <- bwNoteBook(.cdtEnv$tcl$main$cmd.frame)
    cmd.tab1 <- bwAddTab(tknote.cmd, text = lang.dlg[['tab_title']][['1']])
    cmd.tab2 <- bwAddTab(tknote.cmd, text = lang.dlg[['tab_title']][['2']])

    bwRaiseTab(tknote.cmd, cmd.tab1)

    tkgrid.columnconfigure(cmd.tab1, 0, weight = 1)
    tkgrid.columnconfigure(cmd.tab2, 0, weight = 1)

    tkgrid.rowconfigure(cmd.tab1, 0, weight = 1)
    tkgrid.rowconfigure(cmd.tab2, 0, weight = 1)

    #######################################################################################################

    #Tab1
    subfr1 <- bwTabScrollableFrame(cmd.tab1)

        #######################

        frameTimeS <- ttklabelframe(subfr1, text = lang.dlg[['label']][['1']], relief = 'groove')

        timeSteps <- tclVar()
        CbperiodVAL <- .cdtEnv$tcl$lang$global[['combobox']][['1']][3:6]
        periodVAL <- c('daily', 'pentad', 'dekadal', 'monthly')
        tclvalue(timeSteps) <- CbperiodVAL[periodVAL %in% GeneralParameters$intstep]

        cb.fperiod <- ttkcombobox(frameTimeS, values = CbperiodVAL, textvariable = timeSteps, width = largeur0)

        tkgrid(cb.fperiod, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 1, ipadx = 1, ipady = 1)

        helpWidget(cb.fperiod, lang.dlg[['tooltip']][['1']], lang.dlg[['status']][['1']])

        #######################

        frameInData <- ttklabelframe(subfr1, text = lang.dlg[['label']][['2']], relief = 'groove')

        input.file <- tclVar(GeneralParameters$infile)

        txt.infile <- tklabel(frameInData, text = lang.dlg[['label']][['3']], anchor = 'w', justify = 'left')
        cb.infile <- ttkcombobox(frameInData, values = unlist(listOpenFiles), textvariable = input.file, width = largeur1)
        bt.infile <- tkbutton(frameInData, text = "...")

        tkgrid(txt.infile, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 5, padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(cb.infile, row = 1, column = 0, sticky = 'we', rowspan = 1, columnspan = 4, padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.infile, row = 1, column = 4, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 1, ipadx = 1, ipady = 1)

        helpWidget(cb.infile, lang.dlg[['tooltip']][['2']], lang.dlg[['status']][['2']])
        helpWidget(bt.infile, lang.dlg[['tooltip']][['3']], lang.dlg[['status']][['3']])

        ######
        tkconfigure(bt.infile, command = function(){
            dat.opfiles <- getOpenFiles(.cdtEnv$tcl$main$win)
            if(!is.null(dat.opfiles)){
                update.OpenFiles('ascii', dat.opfiles)
                listOpenFiles[[length(listOpenFiles) + 1]] <<- dat.opfiles[[1]]
                tclvalue(input.file) <- dat.opfiles[[1]]
                tkconfigure(cb.infile, values = unlist(listOpenFiles))
            }
        })

        #######################

        frameStatH <- ttklabelframe(subfr1, text = lang.dlg[['label']][['4']], relief = 'groove')

        hom.method <- tclVar()
        CbMETHOD.MTH <- lang.dlg[['combobox']][['1']]
        METHOD.MTH <- c('Pettitt', 'SNHT', 'CUSUM', 'CUSUMtr')
        tclvalue(hom.method) <- CbMETHOD.MTH[METHOD.MTH %in% GeneralParameters$stats$mthd]

        cb.hom.mthd <- ttkcombobox(frameStatH, values = CbMETHOD.MTH, textvariable = hom.method, width = largeur3)
        bt.hom.mthd <- ttkbutton(frameStatH, text = .cdtEnv$tcl$lang$global[['button']][['5']])

        tkgrid(cb.hom.mthd, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 3, padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.hom.mthd, row = 0, column = 3, sticky = 'e', rowspan = 1, columnspan = 2, padx = 1, pady = 1, ipadx = 1, ipady = 1)

        helpWidget(cb.hom.mthd, lang.dlg[['tooltip']][['4']], lang.dlg[['status']][['4']])
        helpWidget(bt.hom.mthd, lang.dlg[['tooltip']][['5']], lang.dlg[['status']][['5']])

        ######
        tkconfigure(bt.hom.mthd, command = function(){
            if(trimws(tclvalue(hom.method)) == CbMETHOD.MTH[2])
                CONF.LEV <- c('90.0', '92.0', '94.0', '95.0', '97.5', '99.0')
            else
                CONF.LEV <- c('90.0', '92.0', '95.0', '97.5', '99.0', '99.9')

            Params <- GeneralParameters[["stats"]]
            GeneralParameters[["stats"]] <<- getParams.HomogMethod(Params, CONF.LEV)
        })

        #######################

        frameRefS <- tkframe(subfr1, relief = 'groove', borderwidth = 2)

        use.RefS <- tclVar(GeneralParameters$series$use)

        chk.RefS <- tkcheckbutton(frameRefS, variable = use.RefS, text = lang.dlg[['checkbutton']][['1']], anchor = 'w', justify = 'left', width = largeur4)
        bt.RefS <- ttkbutton(frameRefS, text = .cdtEnv$tcl$lang$global[['button']][['5']], state = "disabled")

        tkgrid(chk.RefS, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 3, padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.RefS, row = 0, column = 3, sticky = 'we', rowspan = 1, columnspan = 2, padx = 2, pady = 1, ipadx = 1, ipady = 1)

        helpWidget(chk.RefS, lang.dlg[['tooltip']][['6']], lang.dlg[['status']][['6']])
        helpWidget(bt.RefS, lang.dlg[['tooltip']][['7']], lang.dlg[['status']][['7']])

        ######
        tkconfigure(bt.RefS, command = function(){
            Params <- GeneralParameters[["series"]]
            GeneralParameters[["series"]] <<- getParams.HomoRefSeries(Params)
        })

        ######
        tkbind(chk.RefS, "<Button-1>", function(){
            if(tclvalue(QCExist) == '0'){
                stateRefS <- if(tclvalue(use.RefS) == '1') 'disabled' else 'normal'
                tkconfigure(bt.RefS, state = stateRefS)
            }
        })

        #######################

        bt.aggrPars <- ttkbutton(subfr1, text = lang.dlg[['button']][['1']])

        tkconfigure(bt.aggrPars, command = function(){
            GeneralParameters[['aggr']] <<- getInfo_AggregateFun(.cdtEnv$tcl$main$win,
                                                                 GeneralParameters[['aggr']],
                                                                 c("sum", "mean"))
        })

        #######################

        frameDirSav <- tkframe(subfr1, relief = 'groove', borderwidth = 2)

        dir.save <- tclVar(GeneralParameters$outdir)

        txt.dir.save <- tklabel(frameDirSav, text = lang.dlg[['label']][['5']], anchor = 'w', justify = 'left')
        en.dir.save <- tkentry(frameDirSav, textvariable = dir.save, width = largeur2)
        bt.dir.save <- tkbutton(frameDirSav, text = "...")

        tkgrid(txt.dir.save, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 5, padx = 1, pady = 0, ipadx = 1, ipady = 1)
        tkgrid(en.dir.save, row = 1, column = 0, sticky = 'we', rowspan = 1, columnspan = 4, padx = 0, pady = 0, ipadx = 1, ipady = 1)
        tkgrid(bt.dir.save, row = 1, column = 4, sticky = 'w', rowspan = 1, columnspan = 1, padx = 0, pady = 0, ipadx = 1, ipady = 1)

        helpWidget(en.dir.save, lang.dlg[['tooltip']][['8']], lang.dlg[['status']][['8']])
        helpWidget(bt.dir.save, lang.dlg[['tooltip']][['9']], lang.dlg[['status']][['9']])

        ######
        tkconfigure(bt.dir.save, command = function() fileORdir2Save(dir.save, isFile = FALSE))

        #############################

        bt.HomogTest <- ttkbutton(subfr1, text = lang.dlg[['button']][['2']])

        tkconfigure(bt.HomogTest, command = function(){
            GeneralParameters$intstep <- periodVAL[CbperiodVAL %in% trimws(tclvalue(timeSteps))]
            GeneralParameters$infile <- trimws(tclvalue(input.file))
            GeneralParameters$outdir <- trimws(tclvalue(dir.save))

            GeneralParameters$stats$mthd <- METHOD.MTH[CbMETHOD.MTH %in% trimws(tclvalue(hom.method))]
            GeneralParameters$series$use <- switch(tclvalue(use.RefS), '0' = FALSE, '1' = TRUE)

            # assign('GeneralParameters', GeneralParameters, envir = .GlobalEnv)

            Insert.Messages.Out(lang.dlg[['message']][['1']], TRUE, "i")

            tkconfigure(.cdtEnv$tcl$main$win, cursor = 'watch')
            tcl('update')
            ret <- tryCatch(
                {
                    homogeneityTestProcs(GeneralParameters)
                },
                warning = function(w){
                    warningFun(w)
                    return(0)
                },
                error = function(e) errorFun(e),
                finally = {
                    tkconfigure(.cdtEnv$tcl$main$win, cursor = '')
                    tcl('update')
                }
            )

            if(!is.null(ret)){
                if(ret == 0){
                    Insert.Messages.Out(lang.dlg[['message']][['2']], TRUE, "s")
                    set.station.id()
                }else Insert.Messages.Out(lang.dlg[['message']][['3']], TRUE, 'e')
            }else Insert.Messages.Out(lang.dlg[['message']][['3']], TRUE, 'e')
        })

        #########################################

        tkgrid(frameTimeS, row = 0, column = 0, sticky = '', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(frameInData, row = 1, column = 0, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(frameStatH, row = 2, column = 0, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(frameRefS, row = 3, column = 0, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.aggrPars, row = 4, column = 0, sticky = 'we', padx = 1, pady = 3, ipadx = 1, ipady = 1)
        tkgrid(frameDirSav, row = 5, column = 0, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.HomogTest, row = 6, column = 0, sticky = 'we', padx = 1, pady = 3, ipadx = 1, ipady = 1)

    #######################################################################################################

    #Tab2
    subfr2 <- bwTabScrollableFrame(cmd.tab2)

        ##############################################

        frameOutQC <- ttklabelframe(subfr2, text = lang.dlg[['label']][['6']], relief = 'groove')

        QCExist <- tclVar(0)
        file.dataIndex <- tclVar()

        chk.dataIdx <- tkcheckbutton(frameOutQC, variable = QCExist, text = lang.dlg[['checkbutton']][['2']], anchor = 'w', justify = 'left')
        en.dataIdx <- tkentry(frameOutQC, textvariable = file.dataIndex, width = largeur2 + 5, state = "disabled")
        bt.dataIdx <- ttkbutton(frameOutQC, text = .cdtEnv$tcl$lang$global[['button']][['6']], state = "disabled")

        tkgrid(chk.dataIdx, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 4, padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.dataIdx, row = 0, column = 4, sticky = 'e', rowspan = 1, columnspan = 1, padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(en.dataIdx, row = 1, column = 0, sticky = 'we', rowspan = 1, columnspan = 5, padx = 1, pady = 1, ipadx = 1, ipady = 1)

        ##############

        tkconfigure(bt.dataIdx, command = function(){
            path.dataIdx <- tclvalue(tkgetOpenFile(initialdir = getwd(), filetypes = .cdtEnv$tcl$data$filetypes6))
            if(path.dataIdx %in% c("", "NA") | is.na(path.dataIdx)) return(NULL)
            tclvalue(file.dataIndex) <- path.dataIdx

            if(file.exists(trimws(tclvalue(file.dataIndex)))){
                OutQC <- try(readRDS(trimws(tclvalue(file.dataIndex))), silent = TRUE)
                if(inherits(OutQC, "try-error")){
                    Insert.Messages.Out(lang.dlg[['message']][['4']], TRUE, 'e')
                    Insert.Messages.Out(gsub('[\r\n]', '', OutQC[1]), TRUE, 'e')
                    tkconfigure(.cdtData$EnvData$STN$cb.stnID, values = "")
                    tclvalue(.cdtData$EnvData$STN$stnID) <- ""
                    return(NULL)
                }

                .cdtData$EnvData$output <- OutQC
                .cdtData$EnvData$PathData <- dirname(trimws(tclvalue(file.dataIndex)))

                ###############
                file.table <- file.path(.cdtData$EnvData$PathData, 'CDTDATASET', "BreaksPointsTable.rds")
                if(!file.exists(file.table)){
                    Insert.Messages.Out(paste(file.table, lang.dlg[['message']][['5']]), TRUE, 'e')
                    return(NULL)
                }
                .cdtData$EnvData$cpt.table <- readRDS(file.table)

                ###############
                file.table0 <- file.path(.cdtData$EnvData$PathData, 'CDTDATASET', "BreaksPointsTable0.rds")
                if(!file.exists(file.table0)){
                    Insert.Messages.Out(paste(file.table0, lang.dlg[['message']][['5']]), TRUE, 'e')
                    return(NULL)
                }
                .cdtData$EnvData$cpt.table0 <- readRDS(file.table0)

                ###############
                file.candS <- file.path(.cdtData$EnvData$PathData, 'CDTDATASET', "CandidateSeries.rds")
                if(!file.exists(file.candS)){
                    Insert.Messages.Out(paste(file.candS, lang.dlg[['message']][['5']]), TRUE, 'e')
                    return(NULL)
                }
                .cdtData$EnvData$candS <- readRDS(file.candS)

                ###############
                file.testS <- file.path(.cdtData$EnvData$PathData, 'CDTDATASET', "TestSeries.rds")
                if(!file.exists(file.testS)){
                    Insert.Messages.Out(paste(file.testS, lang.dlg[['message']][['5']]), TRUE, 'e')
                    return(NULL)
                }
                .cdtData$EnvData$testS <- readRDS(file.testS)

                ###############
                file.stats <- file.path(.cdtData$EnvData$PathData, 'CDTDATASET', "BreaksPointsStats.rds")
                if(!file.exists(file.stats)){
                    Insert.Messages.Out(paste(file.stats, lang.dlg[['message']][['5']]), TRUE, 'e')
                    return(NULL)
                }
                .cdtData$EnvData$cpt.stats <- readRDS(file.stats)

                tclvalue(timeSteps) <- CbperiodVAL[periodVAL %in% .cdtData$EnvData$output$params$intstep]

                set.station.id()
            }
        })

        ###############
        tkbind(chk.dataIdx, "<Button-1>", function(){
            stateExistData <- if(tclvalue(QCExist) == '1') 'disabled' else 'normal'
            tkconfigure(en.dataIdx, state = stateExistData)
            tkconfigure(bt.dataIdx, state = stateExistData)

            stateQC <- if(tclvalue(QCExist) == '1') 'normal' else 'disabled'
            tcl(tknote.cmd, 'itemconfigure', cmd.tab1$IDtab, state = stateQC)
        })

        #############################

        frameStnId <- ttklabelframe(subfr2, text = lang.dlg[['label']][['7']], relief = 'groove')

        .cdtData$EnvData$STN$stnID <- tclVar()

        bt.stnID.prev <- ttkbutton(frameStnId, text = "<<", width = largeur7)
        bt.stnID.next <- ttkbutton(frameStnId, text = ">>", width = largeur7)
        .cdtData$EnvData$STN$cb.stnID <- ttkcombobox(frameStnId, values = "", textvariable = .cdtData$EnvData$STN$stnID, width = largeur5, justify = 'center')

        tkgrid(bt.stnID.prev, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 2, ipadx = 1, ipady = 1)
        tkgrid(.cdtData$EnvData$STN$cb.stnID, row = 0, column = 1, sticky = 'we', rowspan = 1, columnspan = 2, padx = 3, pady = 2, ipadx = 1, ipady = 1)
        tkgrid(bt.stnID.next, row = 0, column = 3, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 2, ipadx = 1, ipady = 1)

        ######
        tkconfigure(bt.stnID.prev, command = function(){
            if(!is.null(.cdtData$EnvData$output$data)){
                STNID <- .cdtData$EnvData$output$data$id
                istn <- which(STNID == trimws(tclvalue(.cdtData$EnvData$STN$stnID)))
                istn <- istn - 1
                if(istn < 1) istn <- length(STNID)
                tclvalue(.cdtData$EnvData$STN$stnID) <- STNID[istn]
            }
        })

        tkconfigure(bt.stnID.next, command = function(){
            if(!is.null(.cdtData$EnvData$output$data)){
                STNID <- .cdtData$EnvData$output$data$id
                istn <- which(STNID == trimws(tclvalue(.cdtData$EnvData$STN$stnID)))
                istn <- istn + 1
                if(istn > length(STNID)) istn <- 1
                tclvalue(.cdtData$EnvData$STN$stnID) <- STNID[istn]
            }
        })

        #######################

        frameEdit <- tkframe(subfr2)

        bt.display.Hom <- ttkbutton(frameEdit, text = lang.dlg[['button']][['3']], width = largeur10)
        bt.undo.Hom <- ttkbutton(frameEdit, text = lang.dlg[['button']][['4']], width = largeur10)

        tkgrid(bt.display.Hom, row = 0, column = 0, rowspan = 1, columnspan = 1, sticky = 'we', padx = 3, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.undo.Hom, row = 0, column = 1, rowspan = 1, columnspan = 1, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)

        ######
        .cdtData$EnvData$tab$TableStat <- NULL

        tkconfigure(bt.display.Hom, command = function(){
            if(is.null(.cdtData$EnvData$cpt.table)) return(NULL)
            display.cpt.output()
        })

        tkconfigure(bt.undo.Hom, command = function(){
            if(is.null(.cdtData$EnvData$cpt.table)) return(NULL)
            stnid <- trimws(tclvalue(.cdtData$EnvData$STN$stnID))
            if(stnid == "") return(NULL)
            for(j in 1:3){
                if(is.null(.cdtData$EnvData$cpt.table0[[j]])) next
                replaceNULL <- vector('list', 1)
                names(replaceNULL) <- stnid
                old.cpt.table <- .cdtData$EnvData$cpt.table[[j]]
                .cdtData$EnvData$cpt.table[[j]] <- utils::modifyList(old.cpt.table, replaceNULL, keep.null = TRUE)

                replace0 <- .cdtData$EnvData$cpt.table0[[j]][stnid]
                old.cpt.table <- .cdtData$EnvData$cpt.table[[j]]
                .cdtData$EnvData$cpt.table[[j]] <- utils::modifyList(old.cpt.table, replace0, keep.null = TRUE)
            }

            file.table <- file.path(.cdtData$EnvData$PathData, 'CDTDATASET', "BreaksPointsTable.rds")
            saveRDS(.cdtData$EnvData$cpt.table, file.table)

            display.cpt.output()
        })

        #######################

        framePlot <- tkframe(subfr2)

        plotseries <- tclVar()
        CbplotSeriesVAL <- lang.dlg[['combobox']][['2']]
        plotSeriesVAL <- c('testSeries', 'BaseSeries')
        tclvalue(plotseries) <- CbplotSeriesVAL[plotSeriesVAL %in% GeneralParameters$plotSeries]

        cb.Plot.Hom <- ttkcombobox(framePlot, values = CbplotSeriesVAL, textvariable = plotseries, width = largeur6)
        bt.Plot.Hom <- ttkbutton(framePlot, text = .cdtEnv$tcl$lang$global[['button']][['3']], width = largeur8)

        tkgrid(cb.Plot.Hom, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 1, padx = 3, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.Plot.Hom, row = 0, column = 1, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 1, ipadx = 1, ipady = 1)

        ######
        .cdtData$EnvData$tab$breakpts <- NULL

        tkconfigure(bt.Plot.Hom, command = function(){
            stnid <- trimws(tclvalue(.cdtData$EnvData$STN$stnID))
            if(stnid == "") return(NULL)
            tab.title <- paste0(stnid, "-BreakPoints")

            imgContainer <- homDislpay_BreakPoints(.cdtData$EnvData$tab$breakpts, tab.title)
            .cdtData$EnvData$tab$breakpts <- imageNotebookTab_unik(imgContainer, .cdtData$EnvData$tab$breakpts)
        })

        ######
        .cdtData$EnvData$plot$plotseries <- GeneralParameters$plotSeries

        tkbind(cb.Plot.Hom, "<<ComboboxSelected>>", function(){
            .cdtData$EnvData$plot$plotseries <- plotSeriesVAL[CbplotSeriesVAL %in% trimws(tclvalue(plotseries))]
        })

        #######################

        frameAdjust <- tkframe(subfr2, relief = 'groove', borderwidth = 2)

        adjseries <- tclVar()
        CbadjSeriesVAL <- lang.dlg[['combobox']][['3']]
        adjSeriesVAL <- c('none', 'mean', 'qm')
        tclvalue(adjseries) <- CbadjSeriesVAL[adjSeriesVAL %in% GeneralParameters$adjSeries]

        txt.adjust <- tklabel(frameAdjust, text = lang.dlg[['label']][['8']], anchor = 'w', justify = 'left')
        bt.adjust <- ttkbutton(frameAdjust, text = .cdtEnv$tcl$lang$global[['button']][['5']], width = largeur8)
        cb.Adj.Hom <- ttkcombobox(frameAdjust, values = CbadjSeriesVAL, textvariable = adjseries, width = largeur6)
        bt.Adj.Hom <- ttkbutton(frameAdjust, text = lang.dlg[['button']][['5']], width = largeur8)

        tkgrid(txt.adjust, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 1, padx = 2, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.adjust, row = 0, column = 1, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(cb.Adj.Hom, row = 1, column = 0, sticky = 'we', rowspan = 1, columnspan = 1, padx = 2, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.Adj.Hom, row = 1, column = 1, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 1, ipadx = 1, ipady = 1)

        helpWidget(bt.adjust, lang.dlg[['tooltip']][['10']], lang.dlg[['status']][['10']])

        ######
        tkconfigure(bt.Adj.Hom, command = function(){
            on.exit({
                tkconfigure(.cdtEnv$tcl$main$win, cursor = '')
                tcl('update')
            })
            tkconfigure(.cdtEnv$tcl$main$win, cursor = 'watch')
            tcl('update')

            stnid <- trimws(tclvalue(.cdtData$EnvData$STN$stnID))
            if(stnid == "") return(NULL)
            if(is.null(.cdtData$EnvData$cpt.table)) return(NULL)

            STNID <- .cdtData$EnvData$output$data$id
            ids <- which(STNID == stnid)
            adj.mthd <- adjSeriesVAL[CbadjSeriesVAL %in% trimws(tclvalue(adjseries))]

            .cdtData$EnvData$output$params[['adj']] <- GeneralParameters[["adj"]]
            parsAdj <- .cdtData$EnvData$output$params[['adj']]
            parsStat <- .cdtData$EnvData$output$params[['stats']]

            Xl <- lapply(.cdtData$EnvData$candS, function(x){
                if(is.null(x)) return(NULL)
                don <- x$data[, ids]
                x$data <- don
                x
            })

            cpt.table <- lapply(.cdtData$EnvData$cpt.table, function(x){
                if(is.null(x)) return(NULL)
                x[[stnid]]
            })
            inull <- sapply(cpt.table, is.null)

            if(adj.mthd != "none" & !all(inull)){
                .cdtData$EnvData$adjS <- homog.AdjustSeries(Xl, cpt.table, parsStat, parsAdj)
            }else{
                .cdtData$EnvData$adjS <- lapply(Xl, function(x){
                    if(is.null(x)) return(NULL)
                    x$data <- matrix(x$data, nrow = length(x$data), ncol = 3)
                    x
                })
            }

            istn <- ids + 1
            idon <- switch(adj.mthd, "none" = 1, "mean" = 2, "qm" = 3)

            is.elv <- if(is.null(.cdtData$EnvData$output$data$elv)) 3 else 4
            info <- .cdtData$EnvData$output$info[[3]]

            ret <- lapply(.cdtData$EnvData$adjS, function(don){
                if(is.null(don)) return(NULL)
                file.stn <- file.path(.cdtData$EnvData$PathData, 'CDTSTATIONS', paste0(toupper(don$tstep), '_', .cdtData$EnvData$output$info[[1]]))
                tmp <- utils::read.table(file.stn, header = FALSE, sep = info$sepr, stringsAsFactors = FALSE, colClasses = "character")
                idaty <- seq(nrow(tmp))[-(1:is.elv)]
                tmp[idaty, istn] <- as.character(round(don$data[, idon], 1))
                utils::write.table(tmp, file = file.stn, quote = FALSE, sep = info$sepr, row.names = FALSE, col.names = FALSE, na = info$miss.val)
            })

            Insert.Messages.Out(paste(stnid, ':', lang.dlg[['message']][['6']]), TRUE, "s")
        })

        tkconfigure(bt.adjust, command = function(){
            states <- list(day = c('Day', 'normal', 'normal'),
                           pen = c('Pentad', 'normal', 'normal'),
                           dek = c('Day', 'disabled', 'normal'),
                           mon = c('Day', 'disabled', 'disabled'))

            states <- unlist(states[CbperiodVAL %in% trimws(tclvalue(timeSteps))])
            label <- states[1]
            state.dyp <- states[2]
            state.dek <- states[3]
            Params <- GeneralParameters[["adj"]]
            GeneralParameters[["adj"]] <<- getParams.HomogAdjust(Params, label, state.dyp, state.dek)
        })

        #######################

        framePlotAdj <- tkframe(subfr2)

        frAdjSel <- tkframe(framePlotAdj, relief = 'sunken', borderwidth = 2)

        .cdtData$EnvData$plot$base <- tclVar(TRUE)
        .cdtData$EnvData$plot$mean <- tclVar(FALSE)
        .cdtData$EnvData$plot$qm <- tclVar(FALSE)

        chk.Adj.BaseS <- tkcheckbutton(frAdjSel, variable = .cdtData$EnvData$plot$base, text = lang.dlg[['checkbutton']][['3']], anchor = 'w', justify = 'left')
        chk.Adj.Mean <- tkcheckbutton(frAdjSel, variable = .cdtData$EnvData$plot$mean, text = lang.dlg[['checkbutton']][['4']], anchor = 'w', justify = 'left')
        chk.Adj.QM <- tkcheckbutton(frAdjSel, variable = .cdtData$EnvData$plot$qm, text = lang.dlg[['checkbutton']][['5']], anchor = 'w', justify = 'left')

        bt.PlotAdj <- ttkbutton(framePlotAdj, text = lang.dlg[['button']][['6']], width = largeur9)

        tkgrid(chk.Adj.BaseS, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 0, ipadx = 1, ipady = 1)
        tkgrid(chk.Adj.Mean, row = 1, column = 0, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 0, ipadx = 1, ipady = 1)
        tkgrid(chk.Adj.QM, row = 2, column = 0, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 0, ipadx = 1, ipady = 1)

        tkgrid(frAdjSel, row = 0, column = 0, sticky = 'we', rowspan = 1, columnspan = 1, padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.PlotAdj, row = 0, column = 1, sticky = 'we', rowspan = 3, columnspan = 1, padx = 1, pady = 1, ipadx = 1, ipady = 1)

        ######
        .cdtData$EnvData$tab$adjGraph <- NULL

        tkconfigure(bt.PlotAdj, command = function(){
            if(is.null(.cdtData$EnvData$adjS)){
                Insert.Messages.Out(lang.dlg[['message']][['7']], TRUE, 'e')
                return(NULL)
            }
            stnid <- trimws(tclvalue(.cdtData$EnvData$STN$stnID))

            imgContainer <- CDT.Display.Graph(homPlot_AdjustedSeries, .cdtData$EnvData$tab$adjGraph, paste0(stnid, '-Adjusted-Series'))
            .cdtData$EnvData$tab$adjGraph<- imageNotebookTab_unik(imgContainer, .cdtData$EnvData$tab$adjGraph)
        })

        #######################

        bt.display.Info <- ttkbutton(subfr2, text = lang.dlg[['button']][['7']])

        .cdtData$EnvData$tab$infoHom <- NULL

        tkconfigure(bt.display.Info, command = function(){
            stnid <- trimws(tclvalue(.cdtData$EnvData$STN$stnID))
            if(stnid == "") return(NULL)
            STNID <- .cdtData$EnvData$output$data$id
            ids <- which(STNID == stnid)

            test <- .cdtData$EnvData$output$params$stats$mthd
            stats.test <- c("Pettitt Test", "SNHT (Alexandersson & Moberg, 1997)",
                            "CUSUM-type (Gallagher et al., 2013)",
                            "CUSUM-type with Trend (Gallagher et al., 2013)")
            sel.test <- c('Pettitt', 'SNHT', 'CUSUM', 'CUSUMtr')

            INFOs <- list(Stations = stnid,
                          info = .cdtData$EnvData$output$series$msg[[stnid]],
                          statistics = stats.test[sel.test %in% test],
                          detection.method = "Binary Segmentation",
                          penality = "Modified Bayes Information Criterion",
                          changepoints.stats = local({
                                cpt.stats <- lapply(seq(.cdtData$EnvData$cpt.stats), function(j){
                                    x <- .cdtData$EnvData$cpt.stats[[j]]
                                    if(is.null(x)) return(NULL)
                                    list(out = x[[stnid]], tstep = .cdtData$EnvData$candS[[j]]$tstep)
                                })
                                nomS <- sapply(cpt.stats, "[[", "tstep")
                                cpt.stats <- lapply(cpt.stats, "[[", "out")
                                names(cpt.stats) <- nomS
                                cpt.stats
                        }),
                        reference.series = local({
                            mat <- NULL
                            if(.cdtData$EnvData$output$params$series$use){
                                if(.cdtData$EnvData$output$params$series$user$refs){
                                    mat <- "Stations provided by User"
                                }else{
                                    mat <- matrix(character(0), 2, 2)
                                    mat[1, 1] <- "Test series constitution :"
                                    mat[1, 2] <- c("Difference", "Ratio", "LogRatio")[.cdtData$EnvData$output$params$series$diff.ratio]
                                    mat[2, 1] <- "Weighting factors :"
                                    mat[2, 2] <- c("Correlation", "Distance", "Optimal")[.cdtData$EnvData$output$params$series$weight]
                                }
                            }
                            mat
                        }),
                        neighborhood = .cdtData$EnvData$output$series$voisin1[[ids]])

            .cdtData$EnvData$tab$infoHom <- consolOutNotebookTab_unik(INFOs, .cdtData$EnvData$tab$infoHom, title = "Info-Test-Output")
        })

        #########################################

        tkgrid(frameOutQC, row = 0, column = 0, rowspan = 1, columnspan = 1, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(frameStnId, row = 1, column = 0, rowspan = 1, columnspan = 1, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(frameEdit, row = 2, column = 0, rowspan = 1, columnspan = 1, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(framePlot, row = 3, column = 0, rowspan = 1, columnspan = 1, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(frameAdjust, row = 4, column = 0, rowspan = 1, columnspan = 1, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(framePlotAdj, row = 5, column = 0, rowspan = 1, columnspan = 1, sticky = 'we', padx = 1, pady = 1, ipadx = 1, ipady = 1)
        tkgrid(bt.display.Info, row = 6, column = 0, rowspan = 1, columnspan = 1, sticky = 'we', padx = 1, pady = 3, ipadx = 1, ipady = 1)

    #######################################################################################################

    set.station.id <- function(){
        STNID <- .cdtData$EnvData$output$data$id
        tkconfigure(.cdtData$EnvData$STN$cb.stnID, values = STNID)
        tclvalue(.cdtData$EnvData$STN$stnID) <- STNID[1]
    }

    display.cpt.output <- function(){
        stnid <- trimws(tclvalue(.cdtData$EnvData$STN$stnID))
        if(stnid == "") return(NULL)

        cpt.table <- lapply(seq_along(.cdtData$EnvData$cpt.table), function(j){
            x <- .cdtData$EnvData$cpt.table[[j]]
            if(is.null(x)) return(NULL)
            out <- x[[stnid]]
            if(is.null(out)) return(NULL)
            rownames(out) <- NULL
            data.frame(Time.Step = .cdtData$EnvData$candS[[j]]$tstep, out, stringsAsFactors = FALSE)
        })

        inull <- sapply(cpt.table, is.null)
        cpt.table <- cpt.table[!inull]
        if(length(cpt.table) == 0){
            Insert.Messages.Out(lang.dlg[['message']][['23']])
            return(NULL)
        }

        nb.cpt <- do.call(c, lapply(cpt.table, nrow))
        cpt.table <- do.call(rbind, rbind(cpt.table, NA))
        tab.title <- paste0(stnid, "-Test-Output")

        .cdtData$EnvData$tab$TableStat <- tableNotebookTab_unik(cpt.table, .cdtData$EnvData$tab$TableStat, tab.title, 12, 'outhom')
        menuInsertDeleteRow.OpenTable()

        tabid <- as.integer(tclvalue(tkindex(.cdtEnv$tcl$main$tknotes, 'current'))) + 1
        table1 <- .cdtData$OpenTab$Data[[tabid]][[2]][[1]]
        TableArray <- .cdtData$OpenTab$Data[[tabid]][[2]][[2]]

        cols <- paste(1:as.integer(tclvalue(tkindex(table1, 'end', 'row'))), 2, sep = ',', collapse = ' ')
        .Tcl(paste(table1, 'tag', 'celltag', 'datyCol', cols))
        tcl(table1, "tag", "configure", "datyCol", bg = "lightgoldenrod1", anchor = "c")

        if(length(nb.cpt) > 1){
            sep.table <- cumsum(nb.cpt + 1)[-length(nb.cpt)]
            for(j in seq_along(sep.table)){
                rows <- paste(sep.table[j], 1:6, sep = ',', collapse = ' ')
                .Tcl(paste(table1, 'tag', 'celltag', paste0("sepTable", j), rows))
                tcl(table1, "tag", "configure", paste0("sepTable", j), bg = "red")
                .Tcl(paste(table1, "span", paste0(sep.table[j], ",3 0,3")))
                TableArray[sep.table[j], 3] <- "{Do not delete this row}"
            }
        }
    }

    .cdtData$EnvData$HomTest$SaveEdit <- function(dat2sav){
        stnid <- trimws(tclvalue(.cdtData$EnvData$STN$stnID))

        for(j in 1:3){
            if(is.null(.cdtData$EnvData$cpt.table[[j]])) next
            if(is.null(.cdtData$EnvData$cpt.table[[j]][[stnid]])) next
            replaceNULL <- vector('list', 1)
            names(replaceNULL) <- stnid
            old.cpt.table <- .cdtData$EnvData$cpt.table[[j]]
            .cdtData$EnvData$cpt.table[[j]] <- utils::modifyList(old.cpt.table, replaceNULL, keep.null = TRUE)
        }

        if(!is.null(dat2sav)){
            daty <- as.character(dat2sav$Breakpoints.Date)
            if(length(daty) == 0) return(0)
            ina <- which(is.na(daty))
            s <- c(1, ina + 1)
            if(s[length(s)] > length(daty)) s[length(s)] <- length(daty)
            e <- c(ina - 1, length(daty))
            if(e[1] <= 0) e[1] <- 1
            ie <- e < s
            e[ie] <- s[ie]

            res <- lapply(seq_along(s), function(i){
                x <- dat2sav[s[i]:e[i], , drop = FALSE]
                idt <- trimws(as.character(x$Breakpoints.Date))
                ix <- is.na(idt) | idt == ""
                if(all(ix)) return(NULL)
                x <- x[!ix, , drop = FALSE]
                tstep <- trimws(as.character(x$Time.Step))
                tstep <- unique(tstep[!is.na(tstep) & tstep != ""])
                don <- data.frame(x[, -1, drop = FALSE], stringsAsFactors = FALSE)
                list(tstep = tstep, don = don)
            })

            inull <- sapply(res, is.null)

            if(!all(inull)){
                res <- res[!inull]
                tstep <- sapply(res, "[[", "tstep")
                don <- lapply(res, "[[", "don")
                instep1 <- c("daily", "dekadal", "monthly")
                instep2 <- c("pentad", "dekadal", "monthly")
                ii <- c(match(tstep, instep1), match(tstep, instep2))
                ii <- unique(ii[!is.na(ii)])
                for(j in seq_along(ii))
                    .cdtData$EnvData$cpt.table[[ii[j]]][[stnid]] <- don[[j]]
            }
        }

        file.table <- file.path(.cdtData$EnvData$PathData, 'CDTDATASET', "BreaksPointsTable.rds")
        saveRDS(.cdtData$EnvData$cpt.table, file.table)
    }

    #######################################################################################################

    tkgrid(tknote.cmd, sticky = 'nwes')
    tkgrid.columnconfigure(tknote.cmd, 0, weight = 1)
    tkgrid.rowconfigure(tknote.cmd, 0, weight = 1)

    tcl('update')
    tkgrid(.cdtEnv$tcl$main$cmd.frame, sticky = 'nwes', pady = 1)
    tkgrid.columnconfigure(.cdtEnv$tcl$main$cmd.frame, 0, weight = 1)
    tkgrid.rowconfigure(.cdtEnv$tcl$main$cmd.frame, 0, weight = 1)

    invisible()
}
rijaf-iri/CDT documentation built on July 3, 2024, 2:54 a.m.