log_prefix <- "shiny_module_estructura_modelos.r"
#shiny module estructura - simulacion / modelos

estructura_modelos_ui <- function(id, # escencial para poder armar el componente
                                label = "Comparación con modelos") {

    ns <- NS(id) # namespace para como se va a llamar

    # recordar todos los ids dben ponerse como ns('id_de_cosa')
    tagList(
        # 1 parrafo superior que recuerde los valores especificos para este grafo

        # 1 tabset panel
        # 1 panel random
        # 1 panel smallworld
        # 1 panel free scale ( barabasi albert)
        bs_accordion(id = ns("main_accordeon")) %>%
# UI - DATOS RED ---------------------------------------------------------------
        bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
        bs_append(title = "Datos Red", content = div(
            # htmlOutput(ns('datos_red'))
            p("Datos de la red actual"),
            DT::dataTableOutput(ns('datos_red'))
            )) %>%  # fin div datos de la red / append
# UI - MODELOS ---------------------------------------------------------------
        bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
        bs_append(title = "Modelos", content = div(
            tabsetPanel(type = "tabs",
                        id=ns("estructura_modelos_tabs"),

                        # UI - MODELO ERDOS_RENYI - RANDOM NET -----------------------------------------
                        tabPanel("Red aleatoria",div(
                            br(),
                            div(
                                p("Para la ejecución de una red aleatoria se usa el modelo de Erdos-Renyi basado en nodos y aristas.")
                            ),# fin div disclaimer
                            br(),
                            bs_accordion(id = ns("modelo_random_accordeon")) %>%
                                # modelo parametros --------------------------------------------
                            bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                bs_append(title = "Párametros", content = div(
                                    numericInput(inputId = ns("random_param_iter"),
                                                 label="Iteraciones",min=1,max=1200,value = 100),
                                    numericInput(inputId=ns("random_param_vcount"),
                                                 label="Cant. Vértices.",min=0,max=1200,value = 100),
                                    numericInput(inputId=ns("random_param_ecount"),
                                                 label="Cant. Aristas",min=0,max=10000,value = 100),
                                    actionButton(inputId=ns("random_param_update"),label="Ejecutar modelo"),
                                    actionButton(inputId=ns("random_param_sugerencia"),label="Parámetros sugeridos")
                                )) %>% # fin parametros
                                bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                bs_append(title = "Histogramas", content = div(
                                    pickerInput(
                                        inputId = ns("modelo_random_histo_vars_sel"),
                                        label = "Variables",
                                        choices = modelado_df_vars_list,
                                        #choices = "",#
                                        options = list(
                                            placeholder = 'Seleccionar Variable',
                                            onInitialize = I('function() { this.setValue(""); }'),
                                            'actions-box' = TRUE,
                                            size = 10,
                                            'selected-text-format' = "count > 3",
                                            'deselect-all-text' = "Ninguno",
                                            'select-all-text' = "Todos",
                                            'none-selected-text' = "Sin Selección",
                                            'count-selected-text' = "{0} seleccionados."
                                        ),
                                        multiple = FALSE
                                    ),
                                    br(),
                                    plotOutput(ns("modelo_random_histo_vars"))
                                )) %>% # fin histogramas
                                bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                bs_append(title = "Datos simulación", content = div(
                                    br(),
                                    downloadButton (outputId = ns("modelo_random_datos_simu_DL"), label = "Bajar simulación"),
                                    br(),
                                    DT::dataTableOutput(ns('modelo_random_datos_simu_DT'))
                                ))# fin bajada datos
                        )),# fin tab panel / div de aleatoria
                        # UI - MODELO Watts-Strogatz - Small world -----------------------------------------
                        tabPanel("Mundo pequeño",div(

                            br(),
                            div(
                                p("Para la ejecución de una red mundo pequeño se usa el modelo de Watts-Strogatz")
                            ),# fin div disclaimer
                            br(),
                            bs_accordion(id = ns("modelo_sw_accordeon")) %>%
                                # modelo parametros --------------------------------------------
                            bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                bs_append(title = "Párametros", content = div(
                                    numericInput(inputId = ns("sw_param_iter"),
                                                 label="Iteraciones",min=1,max=1200,value = 100),
                                    numericInput(inputId=ns("sw_param_vcount"),
                                                 label="Cant. Vértices.",min=0,max=1200,value = 100),
                                    numericInput(inputId=ns("sw_vecindad"),
                                                 label="Vecindad",min=0,max=100,value = 5),
                                    sliderInput(inputId=ns("sw_prob_reescritura"),
                                                label="Prob reescritura vértices",
                                                min=0,max=1, step = 0.005,
                                                value = 0.05),
                                    actionButton(inputId=ns("sw_param_update"),label="Ejecutar modelo"),
                                    actionButton(inputId=ns("sw_param_sugerencia"),label="Parámetros sugeridos")
                                )) %>% # fin parametros
                                bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                bs_append(title = "Histogramas", content = div(
                                    pickerInput(
                                        inputId = ns("modelo_sw_histo_vars_sel"),
                                        label = "Variables",
                                        choices = '',
                                        options = list(
                                            placeholder = 'Seleccionar Variable',
                                            onInitialize = I('function() { this.setValue(""); }'),
                                            'actions-box' = TRUE,
                                            size = 10,
                                            'selected-text-format' = "count > 3",
                                            'deselect-all-text' = "Ninguno",
                                            'select-all-text' = "Todos",
                                            'none-selected-text' = "Sin Selección",
                                            'count-selected-text' = "{0} seleccionados."
                                        ),
                                        multiple = FALSE
                                    ),
                                    br(),
                                    plotOutput(ns("modelo_sw_histo_vars"))
                                )) %>% # fin histogramas
                                bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                bs_append(title = "Datos simulación", content = div(
                                    br(),
                                    downloadButton (outputId = ns("modelo_sw_datos_simu_DL"), label = "Bajar simulación"),
                                    br(),
                                    DT::dataTableOutput(ns('modelo_sw_datos_simu_DT'))
                                ))# fin bajada datos

                        )),# fin tab panel / div mundo pequeño
                        # UI - MODELO Barabasi-Albert - SCALE FREE  -----------------------------------------
                        tabPanel("Libre escala",div(

                            br(),
                            div(
                                p("Para la ejecución de una red libre escala se usa el modelo de Barabasi-Albert")
                            ),# fin div disclaimer
                            br(),
                            bs_accordion(id = ns("modelo_ba_accordeon")) %>%
                                # modelo parametros --------------------------------------------
                            bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                bs_append(title = "Párametros", content = div(
                                    numericInput(inputId = ns("ba_param_iter"),
                                                 label="Iteraciones",min=1,max=1200,value = 100),
                                    numericInput(inputId=ns("ba_param_vcount"),
                                                 label="Cant. Vértices.",min=0,max=1200,value = 100),
                                    numericInput(inputId=ns("ba_param_edges_step"),
                                                 label="Aristas por paso",min=0,max=100,value = 5),
                                    sliderInput(inputId=ns("ba_param_pow_pref_att"),
                                                label="Exponente conexión preferencial",
                                                min=0,max=10, step = 0.01,
                                                value = 0.05),
                                    actionButton(inputId=ns("ba_param_update"),label="Ejecutar modelo"),
                                    actionButton(inputId=ns("ba_param_sugerencia"),label="Parámetros sugeridos")
                                )) %>% # fin parametros
                                bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                bs_append(title = "Histogramas", content = div(
                                    pickerInput(
                                        inputId = ns("modelo_ba_histo_vars_sel"),
                                        label = "Variables",
                                        choices = '',
                                        options = list(
                                            placeholder = 'Seleccionar Variable',
                                            onInitialize = I('function() { this.setValue(""); }'),
                                            'actions-box' = TRUE,
                                            size = 10,
                                            'selected-text-format' = "count > 3",
                                            'deselect-all-text' = "Ninguno",
                                            'select-all-text' = "Todos",
                                            'none-selected-text' = "Sin Selección",
                                            'count-selected-text' = "{0} seleccionados."
                                        ),
                                        multiple = FALSE
                                    ),
                                    br(),
                                    plotOutput(ns("modelo_ba_histo_vars"))
                                )) %>% # fin histogramas
                                bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                bs_append(title = "Datos simulación", content = div(
                                    br(),
                                    downloadButton (outputId = ns("modelo_ba_datos_simu_DL"), label = "Bajar simulación"),
                                    br(),
                                    DT::dataTableOutput(ns('modelo_ba_datos_simu_DT'))
                                ))# fin bajada datos

                        ))# fin tab panel / div mundo pequeño
            )# fin  tabsetPanel
        )) %>%  # fin div modelos / append
    # UI - Verificaciones ---------------------------------------------------------------
        bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
        bs_append(title = "Validaciones", content = div(

            tabsetPanel(type = "tabs",
                        id=ns("estructura_modelos_tabs"),

# UI - VERIFICACION - SMALL WORLD -----------------------------------------
                        tabPanel("Mundo Pequeño",div(

                            conditionalPanel("input.random_param_update",
                                             div(
# UI - small world - Parametros -------------------------------------------

                                                 bs_accordion(id = ns("small_world_verificacion")) %>%
                                                     bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                                     bs_append(title = "Parámetros", content = div(
                                                         uiOutput(ns("small_world_params"))
                                                     )) %>%
# UI - small world - Verificacion 1 -------------------------------------------
                                                     bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                                     bs_append(title = "Validación 1", content = div(
                                                         uiOutput(ns("small_world_validacion_1"))
                                                     )) %>%
# UI - small world - Verificacion 2 -------------------------------------------
                                                    bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                                    bs_append(title = "Validación 2", content = div(
                                                        uiOutput(ns("small_world_validacion_2"))
                                                    )) %>%
# UI - small world - Comparacion -------------------------------------------
                                                    bs_set_opts(panel_type = "info", use_heading_link = FALSE) %>%
                                                    bs_append(title = "Comparación de Validaciones", content = div(
                                                        uiOutput(ns("small_world_comparacion_valores_validaciones"))
                                                    ))

                                                 # uiOutput(ns("small_world"))
                                             ),ns=ns),
                            conditionalPanel("!input.random_param_update",
                                             div(
                                                 p("para validar Mundo pequeño se debe ejecutar la simulación de redes aleatorias.(En el tab de Modelos / Aleatorio). ")
                                             ),ns=ns)
                        )) ,# fin small world
# UI - VERIFICACION - SCALE FREE -----------------------------------------
                        tabPanel("Libre Escala",div(

                            uiOutput(ns("scale_free"))

                        )) # fin scale free
            )# fin tabset panel verificaciones
        ))# fin verificaciones div / append
    )# fin taglist del modulo

}# fun funcion UI

estructura_modelos_server <- function(input, output, session, # parametros de shiny
                                    current_grafo,#, # grafo actual
                                    model_list_global_vars # variable global lista para selecciones
) {

# SERVER - DATOS RED ---------------------------------------------------------------
    # reactive para luego poder extraer aca los valores default para los paramtetros de los modelos
    valores_para_red_reactive <- reactive({
        valores_para_red <- calcular_metricas(current_grafo)
        valores_para_red
    })
    # para mostrar los datos default de la red
    output$datos_red <- DT::renderDataTable ({

        mostrar <- valores_para_red_reactive() %>%
            rename("transitividad"=transitivity,
                   "diámetro"=diameter,
                   "dist. camino medio"=avg_path,
                   "ley pot. alfa"=pow_law_alpha,
                   "ley pot. signif. test KS"=pow_law_ks_p,
                   "alfa > 1"=pow_law_greater_than_2,
                   "test KS significativo"=pow_law_ks_p_is_signif)

        DT::datatable(
            options = list(dom = 't',
                language = list(url = '//cdn.datatables.net/plug-ins/1.10.11/i18n/Spanish.json')),
            mostrar,
            escape = FALSE,
            rownames = FALSE,
            selection = 'none')

    })
# SERVER - MODELO ERDOS_RENYI - RANDOM NET -----------------------------------------
    # observeEvent(input$random_param_update,{
    observeEvent(input$random_param_sugerencia,{
        # current_grafo <- g_aut
        n_v <- igraph::vcount(current_grafo)
        n_e <- igraph::ecount(current_grafo)

        updateNumericInput(session, "random_param_iter", value = 1000)
        updateNumericInput(session, "random_param_vcount", value = n_v)
        updateNumericInput(session, "random_param_ecount", value = n_e)
    })

    modelo_random_semilla_reactive <- reactive({
        semilla <- 12345
        semilla
    })

    modelo_random_ejecucion <- reactive({
        req(input$random_param_update)

        # ret <- simular_random(iter=100,vertex_count=n_v,edge_count=n_e,semilla=12345)
        ret <- simular_random(iter=input$random_param_iter,
                       vertex_count=input$random_param_vcount,
                       edge_count=input$random_param_ecount,
                       semilla=modelo_random_semilla_reactive())# arreglar la semilla
        ret
    })
    modelo_random_params_reactive <- reactive({
        param_list <- data.frame(param_iter=input$random_param_iter,
                                 param_vertex_count=input$random_param_vcount,
                                 param_edge_count=input$random_param_ecount,
                                 param_semilla=modelo_random_semilla_reactive())
        param_list
    })

    modelo_random_resumen_reactive <- reactive({
        param_list <- modelo_random_params_reactive()
        simulacion_random <- modelo_random_ejecucion()
        simulaciones_resumen <- simulaciones_to_resumen_ejecucion(simulacion_random,param_list)
        simulaciones_resumen
    })

#
#     output$modelo_random <- renderPlot({
#         modelo_random_ejecucion
#     })
#
    modelo_random_histo_vars_opts_reactive <- reactive({
        print(paste0("random: ",model_list_global_vars))
        # no toma globales, hay que pasarlo por parametro
        # ret <- estructura_red_nodos_vars_compara_simu_list # es global
        # ret <- colnames(valores_para_red_reactive())
        ret <- model_list_global_vars
        # ret <- listado_variables_seleccion
        ret
    })

    observe({
        # req(input$anio)
        # input$temporal_estructura_refrescar_boton
        updateSelectizeInput(session, "modelo_random_histo_vars_sel",
                             choices = modelo_random_histo_vars_opts_reactive())
    })

    modelo_random_ejecucion_long <- reactive({
        metricas_nodos_long <- modelo_random_ejecucion() %>%
        # ret2 <- ret %>%
            tidyr::gather(metrica,valor,-param_iter,-param_vertex_count,-param_edge_count) %>%
            as_tibble()
        metricas_nodos_long
    })

    output$modelo_random_histo_vars <- renderPlot({
        req(input$modelo_random_histo_vars_sel)

        # metrica_seleccionada <- "transitivity"
        metrica_seleccionada <- input$modelo_random_histo_vars_sel

        data_red <- modelo_random_ejecucion_long() %>%
            #ret2 %>%
            filter(metrica==metrica_seleccionada)

        data_current <- valores_para_red_reactive() %>%
            tidyr::gather(metrica,valor) %>%
            filter(metrica==metrica_seleccionada)

        pl_to_build <- data_red %>% ggplot(aes(valor)) +
            geom_histogram()+
            geom_vline(data=data_current,
                       aes(xintercept=valor,colour="red"),
                       show.legend = FALSE) +
            labs(title=paste0("Histograma de ",metrica_seleccionada),
                 x= metrica_seleccionada,
                 y= "cantidad de simulaciones")+
            theme_light()

        pl_df <- ggplot_build(pl_to_build)
        y_scale <- pl_df$layout$panel_scales_y[[1]]  # Extrae la escala en y
        y_limits <- y_scale$get_limits()   # Se fija los límites
        y_mid <- max(y_limits)/2           # Agarra el punto medio.

        pl <- pl_to_build+geom_text(data=data_current,
                  aes(x=valor,
                      label=paste0(metrica_seleccionada,": ",round(valor,5),"\n"),
                      y=y_mid),
                  colour="red",
                  angle=90)

        # ggplotly(pl)
        pl

    })

    output$modelo_random_datos_simu_DL <- downloadHandler(
        filename = paste("modelos_","random","_", Sys.Date(), '.csv', sep=''), content = function(file) {
            write.csv(modelo_random_ejecucion(), file,row.names = FALSE,fileEncoding = "UTF-8")
        })

    output$modelo_random_datos_simu_DT <- DT::renderDataTable({

        mostrar <- modelo_random_ejecucion() %>%
            select(-starts_with("param_")) %>%
            rename("transitividad."=transitivity,
                   "diámetro"=diameter,
                   "dist.camino medio"=avg_path,
                   "ley pot. alfa"=pow_law_alpha,
                   "ley pot. signif. test KS"=pow_law_ks_p,
                   "alfa > 1"=pow_law_greater_than_2,
                   "test KS significativo"=pow_law_ks_p_is_signif)

        DT::datatable(
            options = list(language = list(url = '//cdn.datatables.net/plug-ins/1.10.11/i18n/Spanish.json')),
            mostrar,
            escape = FALSE,
            rownames = FALSE,
            selection = 'none')
    })

# SERVER - MODELO Watts-Strogatz - Small world -----------------------------------------

    # observeEvent(input$random_param_update,{
    observeEvent(input$sw_param_sugerencia,{
        # current_grafo <- g_aut
        n_v <- igraph::vcount(current_grafo)

        updateNumericInput(session, "sw_param_iter", value = 1000)
        updateNumericInput(session, "sw_param_vcount", value = n_v)
        updateNumericInput(session, "sw_vecindad", value = 5)
        updateSliderInput(session, "sw_prob_reescritura", value = 0.05)
    })

    #
    #     output$modelo_random <- renderPlot({
    #         modelo_random_ejecucion
    #     })
    #
    modelo_sw_histo_vars_opts_reactive <- reactive({
        # no toma globales, hay que pasarlo por parametro
        # ret <- estructura_red_nodos_vars_compara_simu_list # es global
        # ret <- colnames(valores_para_red_reactive())
        ret <- model_list_global_vars
        # ret <- listado_variables_seleccion
        ret
    })

    observe({
        # req(input$anio)
        # input$temporal_estructura_refrescar_boton
        updateSelectizeInput(session, "modelo_sw_histo_vars_sel",
                             choices = modelo_sw_histo_vars_opts_reactive())
    })

    modelo_sw_ejecucion <- reactive({
        req(input$sw_param_update)

        # ret <- simular_random(iter=100,vertex_count=n_v,edge_count=n_e,semilla=12345)
        ret <- simular_small_world(iter = input$sw_param_iter,
                                   vertex_count = input$sw_param_vcount,
                                   vecindad = input$sw_vecindad,
                                   prob_reescritura = input$sw_prob_reescritura,
                                   semilla = 12345)# arreglar la semilla
        ret
    })

    modelo_sw_ejecucion_long <- reactive({
        metricas_nodos_long <- modelo_sw_ejecucion() %>%
            # ret2 <- ret %>%
            tidyr::gather(metrica,valor,
                          -param_iter,-param_vertex_count,
                          -param_vecindad,-param_prob_reescritura) %>%
            as_tibble()
        metricas_nodos_long
    })

    output$modelo_sw_histo_vars <- renderPlot({
        req(input$modelo_sw_histo_vars_sel)

        # metrica_seleccionada <- "transitivity"
        metrica_seleccionada <- input$modelo_sw_histo_vars_sel

        # print(metrica_seleccionada)

        data_red <- modelo_sw_ejecucion_long() %>%
            #ret2 %>%
            filter(metrica==metrica_seleccionada)

        data_current <- valores_para_red_reactive() %>%
            tidyr::gather(metrica,valor) %>%
            filter(metrica==metrica_seleccionada)

        pl_to_build <- data_red %>% ggplot(aes(valor)) +
            geom_histogram()+
            geom_vline(data=data_current,
                       aes(xintercept=valor,colour="red"),
                       show.legend = FALSE) +
            labs(title=paste0("Histograma de ",metrica_seleccionada),
                 x= metrica_seleccionada,
                 y= "cantidad de simulaciones")+
            theme_light()

        pl_df <- ggplot_build(pl_to_build)
        y_scale <- pl_df$layout$panel_scales_y[[1]]  # Extrae la escala en y
        y_limits <- y_scale$get_limits()   # Se fija los límites
        y_mid <- max(y_limits)/2           # Agarra el punto medio.

        pl <- pl_to_build+geom_text(data=data_current,
                                    aes(x=valor,
                                        label=paste0(metrica_seleccionada,": ",round(valor,5),"\n"),
                                        y=y_mid),
                                    colour="red",
                                    angle=90)
        # ggplotly(pl)
        pl

    })

    output$modelo_sw_datos_simu_DL <- downloadHandler(
        filename = paste("modelos_","small_world","_", Sys.Date(), '.csv', sep=''), content = function(file) {
            write.csv(modelo_sw_ejecucion(), file,row.names = FALSE,fileEncoding = "UTF-8")
        })

    output$modelo_sw_datos_simu_DT <- DT::renderDataTable({

        mostrar <- modelo_sw_ejecucion() %>%
            select(-starts_with("param_")) %>%
            rename("transitividad."=transitivity,
                   "diámetro"=diameter,
                   "dist.camino medio"=avg_path,
                   "ley pot. alfa"=pow_law_alpha,
                   "ley pot. signif. test KS"=pow_law_ks_p,
                   "alfa > 1"=pow_law_greater_than_2,
                   "test KS significativo"=pow_law_ks_p_is_signif)

        DT::datatable(
            options = list(language = list(url = '//cdn.datatables.net/plug-ins/1.10.11/i18n/Spanish.json')),
            mostrar,
            escape = FALSE,
            rownames = FALSE,
            selection = 'none')
    })

# SERVER - MODELO Barabasi-Albert - SCALE FREE  -----------------------------------------
    observeEvent(input$ba_param_sugerencia,{
        # current_grafo <- g_aut
        n_v <- igraph::vcount(current_grafo)
        pl_alfa <- valores_para_red_reactive()$pow_law_alpha

        updateNumericInput(session, "ba_param_iter", value = 1000)
        updateNumericInput(session, "ba_param_vcount", value = n_v)
        updateNumericInput(session, "ba_param_edges_step", value = 5)
        updateSliderInput(session, "ba_param_pow_pref_att", value = pl_alfa)
    })

    modelo_ba_histo_vars_opts_reactive <- reactive({
        # no toma globales, hay que pasarlo por parametro
        # ret <- estructura_red_nodos_vars_compara_simu_list # es global
        # ret <- colnames(valores_para_red_reactive())
        ret <- model_list_global_vars
        # ret <- listado_variables_seleccion
        ret
    })

    observe({
        # req(input$anio)
        # input$temporal_estructura_refrescar_boton
        updateSelectizeInput(session, "modelo_ba_histo_vars_sel",
                             choices = modelo_ba_histo_vars_opts_reactive())
    })

     modelo_ba_ejecucion <- reactive({
        req(input$ba_param_update)

        # ret <- simular_random(iter=100,vertex_count=n_v,edge_count=n_e,semilla=12345)
        ret <- simular_scale_free(iter =input$ba_param_iter ,
                                  vertex_count = input$ba_param_vcount,
                                  poder_pref_attach = input$ba_param_pow_pref_att,
                                  m_edges_per_step = input$ba_param_edges_step,
                                  semilla = 12345)# arreglar la semilla

        ret
    })

     modelo_ba_ejecucion_long <- reactive({
         metricas_nodos_long <- modelo_ba_ejecucion() %>%
             # ret2 <- ret %>%
             tidyr::gather(metrica,valor,
                           -param_iter,-param_vertex_count,
                           -param_poder_pref_attach,-param_m_edges_per_step) %>%
             as_tibble()
         metricas_nodos_long
     })

     output$modelo_ba_histo_vars <- renderPlot({
         req(input$modelo_ba_histo_vars_sel)

         # metrica_seleccionada <- "transitivity"
         metrica_seleccionada <- input$modelo_ba_histo_vars_sel

         # print(metrica_seleccionada)

         data_red <- modelo_ba_ejecucion_long() %>%
             #ret2 %>%
             filter(metrica==metrica_seleccionada)

         data_current <- valores_para_red_reactive() %>%
             tidyr::gather(metrica,valor) %>%
             filter(metrica==metrica_seleccionada)

         pl_to_build <- data_red %>% ggplot(aes(valor)) +
             geom_histogram()+
             geom_vline(data=data_current,
                        aes(xintercept=valor,colour="red"),
                        show.legend = FALSE) +
             labs(title=paste0("Histograma de ",metrica_seleccionada),
                  x= metrica_seleccionada,
                  y= "cantidad de simulaciones")+
             theme_light()

         pl_df <- ggplot_build(pl_to_build)
         y_scale <- pl_df$layout$panel_scales_y[[1]]  # Extrae la escala en y
         y_limits <- y_scale$get_limits()   # Se fija los límites
         y_mid <- max(y_limits)/2           # Agarra el punto medio.

         pl <- pl_to_build+geom_text(data=data_current,
                                     aes(x=valor,
                                         label=paste0(metrica_seleccionada,": ",round(valor,5),"\n"),
                                         y=y_mid),
                                     colour="red",
                                     angle=90)
         # ggplotly(pl)
         pl

     })

     output$modelo_ba_datos_simu_DL <- downloadHandler(
         filename = paste("modelos_","scale_free","_", Sys.Date(), '.csv', sep=''), content = function(file) {
             write.csv(modelo_ba_ejecucion(), file,row.names = FALSE,fileEncoding = "UTF-8")
         })

     output$modelo_ba_datos_simu_DT <- DT::renderDataTable({

         mostrar <- modelo_ba_ejecucion() %>%
             select(-starts_with("param_")) %>%
             rename("transitividad."=transitivity,
                    "diámetro"=diameter,
                    "dist.camino medio"=avg_path,
                    "ley pot. alfa"=pow_law_alpha,
                    "ley pot. signif. test KS"=pow_law_ks_p,
                    "alfa > 1"=pow_law_greater_than_2,
                    "test KS significativo"=pow_law_ks_p_is_signif)

         DT::datatable(
             options = list(language = list(url = '//cdn.datatables.net/plug-ins/1.10.11/i18n/Spanish.json')),
             mostrar,
             escape = FALSE,
             rownames = FALSE,
             selection = 'none')
     })
# SERVER - SMALL WORLD ---------------------------------------------------------------

# SERVER - SMALL WORLD - DATOS ------------------------------------------

     small_world_reactive_data <- reactive({
         req(input$random_param_update)
         valores_para_red <- valores_para_red_reactive()
         params <-  modelo_random_params_reactive()
         simulaciones_resumen_random <- modelo_random_resumen_reactive()
         grafo_actual <- current_grafo

         # param_B_smallworldness <- params %>% pull(param_iter)
         # param_long <- params %>%
         #     tidyr::gather(parametro,valor) %>%
         #     as_tibble()
         #
         #
         #
         # # texto_params <-param_long %>% mutate(texto = paste("<p><strong>",str_replace(parametro,"param_",""),"</strong>",valor,"</p>")) %>% pull(texto) %>% paste(collapse = "\n")
         #
         # delta_net <- valores_para_red$avg_path / simulaciones_resumen_random$mean_avg_path_length
         # gamma_net <- valores_para_red$transitivity / simulaciones_resumen_random$mean_transitivity
         #
         # es_small_world <- round(delta_net) == 1  &  gamma_net > 1
         #
         # paste0(param_long$parametro,": ",param_long$valor,collapse = "\n")
         #
         # # validacion 2. solo control interaciones y  lo & hi confidencia. que le dejamos lo default
         # # para generar los 1000 el de smallworldness utiliza: degree.sequence.game
         # # https://www.rdocumentation.org/packages/igraph/versions/0.4.1/topics/degree.sequence.game
         # smallworldness_grafo <- qgraph::smallworldness(x=grafo_actual,B = param_B_smallworldness )
         # es_mayor_a_1 <- smallworldness_grafo > 1
         # es_mayor_a_3 <- smallworldness_grafo > 3
         # parametros_sw <- paste0(param_long$parametro,": ",param_long$valor,collapse = "\n")
         #
         # ret_list <- list('parametros_sw'=parametros_sw,
         #                  'delta_net'=delta_net,
         #                  'gamma_net'=gamma_net,
         #                  'es_small_world'=es_small_world,
         #                  'smallworldness_grafo'=smallworldness_grafo,
         #                  'es_mayor_a_1'=es_mayor_a_1,
         #                  'es_mayor_a_3'=es_mayor_a_3,
         #                  'valores_para_red'=valores_para_red,
         #                  'simulaciones_resumen_random'=simulaciones_resumen_random)
         ret_list <- smallworld_data_calculo(valores_para_red,params,simulaciones_resumen_random,grafo_actual)

         flog.debug(paste0(log_prefix,"  - smallworld data - : "),ret_list,capture = TRUE)
         ret_list
     })

# SERVER - SMALL WORLD - Parametros ------------------------------------------

     output$small_world_params <- renderUI({
         resultado <- div(
             p("comparado con los parametros de simulación aleatoria: "),
             # p(a("para recordar",href="https://stats.stackexchange.com/questions/175492/how-to-test-statistically-whether-my-network-graph-is-a-small-world-network")),
             p("(",em("se sugiere configurar el modelo en Modelos: Red aleatoria"),")"),
             br(),
             div(small_world_reactive_data()$parametros_sw),
             br())
         resultado
     })

# SERVER - SMALL WORLD - validacion 1 ------------------------------------------

     output$small_world_validacion_1 <- renderUI({
         resultado <- div(
             h2("Validación 1:"),
             p("para validar small world se tomó el criterio de comparar la red actual contra redes aleatorias ( lo seleccionado en el tab de Modelos / Aleatorio). "),
             p("la comparación se lleva a cabo en el promedio del camino mas corto VS la media del promedio del camino más corto de las N redes simuladas."),
             p("para mas detalles ver: ",a(href="https://doi.org/10.1063/1.3360561","Bialonski (2010)")," donde se detalla el procedimiento."),

             p(strong("Mundo pequeño: ")," si Delta ~=1 y Gamma > 1"),
             p(strong('Delta = '),'L/Lr. y ',strong('Gamma = '),"C/Cr."),
             p("L: promedio camino más corto "),
             p("Lr: promedio de promedio camino más corto de las simulaciones"),
             p("C: transitivity "),
             p("Cr: promedio de transitivity de las simulaciones"),
             p(strong("Delta: "),small_world_reactive_data()$delta_net),
             p(strong("Gamma: "),small_world_reactive_data()$gamma_net),
             p(strong("Es mundo pequeño: "),if_else(small_world_reactive_data()$es_small_world,"SI","NO")),
             br())
         resultado
     })

# SERVER - SMALL WORLD - Validacion 2 ------------------------------------------

     output$small_world_validacion_2 <- renderUI({
         resultado <- div(
             h2("Validación 2: "),
             p("Una red puede ser considerada 'mundo pequeño ' si la 'smallworldness' es mayor a 1 ",a(href="https://www.rdocumentation.org/packages/qgraph/versions/1.5/topics/smallworldness","(qgraph::smallworldness)")),
             p("Un punto de vista más estricto dice de la red llevarla a 'smallworldness' >= 3 ",a(href="https://journals.plos.org/plosone/article?id=10.1371/journal.pone.0002051","(Humphries & Gurney, 2008)")),
             br(),
             p(strong("smallworldness: "), small_world_reactive_data()$smallworldness_grafo["smallworldness"]),
             p(strong("mayor a 1: "), if_else(small_world_reactive_data()$es_mayor_a_1,"SI","NO")),
             p(strong("mayor a 3: "), if_else(small_world_reactive_data()$es_mayor_a_3,"SI","NO")),
             br())
         resultado
     })

# SERVER - SMALL WORLD - comparacion validaciones ------------------------------------------

     output$small_world_comparacion_valores_validaciones <- renderUI({

         # medidas_a_mostrar <- data.frame('transitivity [red]'=c(small_world_reactive_data()$valores_para_red$transitivity,
         #                                   small_world_reactive_data()$smallworldness_grafo["trans_target"]),
         #            "transitivity [promedio simulaciones]"=c(small_world_reactive_data()$simulaciones_resumen_random$mean_transitivity,
         #                                                     small_world_reactive_data()$smallworldness_grafo["trans_rnd_M"]),
         #            'promedio distancia del camino mas corto [red]'=c(small_world_reactive_data()$valores_para_red$avg_path,
         #                                                              small_world_reactive_data()$smallworldness_grafo["averagelength_target"]),
         #            "promedio distancia del camino mas corto [promedio simulaciones]"=c(small_world_reactive_data()$simulaciones_resumen_random$mean_avg_path_length,
         #                                                                                small_world_reactive_data()$smallworldness_grafo["averagelength_rnd_M"])
         #            )

         # dataTableOutput(renderDataTable(datatable(medidas_a_mostrar)))

         # medidas_a_mostrar

         resultado <- div(
             p("Recordar que para Validación 2, se vuelven a ejecutar simulaciones."),
             p("Sobre las simulaciones de Validación 1, se puede ver su detalle en su pestaña"),
             p("Sobre las simulaciones de Validación 2, se puede ver su detalle en su pestaña"),
             p(strong("para cada variable: "),'valor validación 1 | ','valor validación 2'),
             p(strong("transitivity [red]:"), small_world_reactive_data()$valores_para_red$transitivity,
               " | ",small_world_reactive_data()$smallworldness_grafo["trans_target"]),
             p(strong("transitivity [promedio simulaciones]:"),
               small_world_reactive_data()$simulaciones_resumen_random$mean_transitivity,
               " | ", small_world_reactive_data()$smallworldness_grafo["trans_rnd_M"] ),
             br(),
             # FIXME: revisar lo de smallworldness hasta donde debatirlo un poco.
             p(strong("promedio distancia del camino mas corto [red]:"),
               small_world_reactive_data()$valores_para_red$avg_path,
               " | ",small_world_reactive_data()$smallworldness_grafo["averagelength_target"]),
             p(strong("promedio distancia del camino más corto [promedio simulaciones]:"),
               small_world_reactive_data()$simulaciones_resumen_random$mean_avg_path_length,
               " | ",small_world_reactive_data()$smallworldness_grafo["averagelength_rnd_M"] )
         )
         resultado
     })

     output$small_world <- renderUI({
         req(input$random_param_update)
         valores_para_red <- valores_para_red_reactive()
         params <-  modelo_random_params_reactive()
         simulaciones_resumen_random <- modelo_random_resumen_reactive()

         param_long <- params %>%
             tidyr::gather(parametro,valor) %>%
             as_tibble()
         # texto_params <-param_long %>% mutate(texto = paste("<p><strong>",str_replace(parametro,"param_",""),"</strong>",valor,"</p>")) %>% pull(texto) %>% paste(collapse = "\n")

         delta_net <- valores_para_red$avg_path / simulaciones_resumen_random$mean_avg_path_length
         gamma_net <- valores_para_red$transitivity / simulaciones_resumen_random$mean_transitivity

         es_small_world <- round(delta_net) == 1  &  gamma_net > 1

         paste0(param_long$parametro,": ",param_long$valor,collapse = "\n")

         smallworldness_grafo <- qgraph::smallworldness(current_grafo)
         es_mayor_a_1 <- smallworldness_grafo > 1
         es_mayor_a_3 <- smallworldness_grafo > 3
         wasd <- paste0(param_long$parametro,": ",param_long$valor,collapse = "\n")

         resultado <- div(
             p("comparado con los parametros de simulación aleatoria: "),
             # p(a("para recordar",href="https://stats.stackexchange.com/questions/175492/how-to-test-statistically-whether-my-network-graph-is-a-small-world-network")),
             p("(",em("se sugiere configurar el modelo en Modelos: Red aleatoria"),")"),
             br(),
             div(wasd),
             br(),
             h2("Validación 1:"),
             p("por comparación con redes aleatorias"),
             p("Mundo pequeño: si delta ~=1 & gamma > 1  "),
             p("#delta:=L/Lr. and gamma:=C/Cr."),
             p("L: promedio camino mas corto "),
             p("Lr: promedio de promedio camino mas corto de las simulaciones"),
             p("C: transitivity "),
             p("Cr: promedio de transitivity de las simulaciones"),
             p(strong("Delta: "),delta_net),
             p(strong("Gamma: "),gamma_net),
             p("Es mundo pequeño: ",es_small_world),
             br(),
             h2("Validación 2: "),
             p("Una red puede ser considerada 'mundo pequeño ' si la 'smallworldness' es mayor a 1 ",a(href="https://www.rdocumentation.org/packages/qgraph/versions/1.5/topics/smallworldness","(qgraph::smallworldness)")),
             p("Un punto de vista mas estricto dice de la red llevarla a 'smallworldness' >= 3 ",a(href="https://journals.plos.org/plosone/article?id=10.1371/journal.pone.0002051","(Humphries & Gurney, 2008)")),
             p("Para considerar una red  'mundo pequeño', Es sugerido inspeccionar transitivity substancialmente mas grande que las simulaciones aleatorias, "),
             p("y que el el promedio de distancia del camino más corto es similar o mayor (pero no mucho mayor)"),
             br(),
             p("smallworldness: ", smallworldness_grafo["smallworldness"]),
             p("mayor a 1: ", es_mayor_a_1),
             p("mayor a 3: ", es_mayor_a_3),
             br(),
             p("transitivity [red]:", valores_para_red$transitivity, " | ",smallworldness_grafo["trans_target"]),
             p("transitivity [promedio simulaciones]:", simulaciones_resumen_random$mean_transitivity, " | ", smallworldness_grafo["trans_rnd_M"] ),
             br(),
             # FIXME: revisar lo de smallworldness hasta donde debatirlo un poco.
             p("promedio distancia del camino más corto [red]:", valores_para_red$avg_path, " | ",smallworldness_grafo["averagelength_target"]),
             p("promedio distancia del camino más corto [promedio simulaciones]:", simulaciones_resumen_random$mean_avg_path_length, " | ",smallworldness_grafo["averagelength_rnd_M"] )#,

             # FIXME: SACAR ESTO:
             #p("otro para ver:", "SAND - 5.5.2 Assessing Small World Properties", "de csardi")
         )

         resultado
     })
# SERVER - SCALE FREE ---------------------------------------------------------------
     output$scale_free <- renderUI({

         valores_para_red <- valores_para_red_reactive()
         # para valores 2 : ver http://networksciencebook.com/chapter/4 donde habla de < 2 no free scale
         # por el tema del test de KS, leer el help del paquete, la funcion fit_power_law

         resultado <- div(
             br(),
             p(" Una red Libre escala es una red en la cual su distribución de grado sigue la ley de potencia."),
             p(a(" Barabasi (2016) ",href="http://networksciencebook.com/chapter/4")),# Agregar el link al capitulo 4 del libro de network science.
             p(strong(" Verificamos por la ley de potencia:")),
             p(" Luego de ajustar los grados de la red a la ley de potencia, tenemos que verificar:"),
             # ley de potencia ( power fit law)
             # resultado_fit_ley_potencia$alpha > 2  # 2.515571
             p(strong("El parámetro alfa de la función es mayor que 2?")),
             p("Exponente alfa: ",valores_para_red["pow_law_alpha"]),
             p("El exponente es mayor a 2: ", valores_para_red["pow_law_greater_than_2"]),

             # p("Dada la hipotesis:"),
             # the original data could have been drawn from the fitted power-law distribution.
             p("Los datos originales pueden ser obtenidos dada la distribucion de ley de potencia obtenida."),
             # Small p-values (less than 0.05) indicate that the test rejected the hypothesis
             p("P-Valores pequenios ( Menores a 0.05 ) Indican que el test rechaza la hipotesis "),
             br(),
             p(strong("El test de ajuste de Kolmogorov-Smirnov significativo?")),
             p("p-value test KS: ",valores_para_red["pow_law_ks_p"]),
             p("menor a 0.05:",valores_para_red["pow_law_ks_p_is_signif"]),

             p(if_else(!valores_para_red["pow_law_ks_p_is_signif"] & valores_para_red["pow_law_greater_than_2"],"Es de Libre Escala.","No es de Libre Escala."))

         )
         resultado
     })
}
flog.info(paste0(log_prefix,"  - LOADED"))


# Vector selection operations
# Note that R begins indexing from 1, instead of 0.

# Poker and roulette winnings from Monday to Friday:
poker_vector <- c(140, -50, 20, -120, 240)
roulette_vector <- c(-24, -50, 100, -350, 10)
days_vector <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
names(poker_vector) <- days_vector
names(roulette_vector) <- days_vector

# Define a new variable based on a selection - select one element of the vector
poker_wednesday <- poker_vector[3]

# Define a new variable based on a selection - select combination of elements
poker_midweek <- poker_vector[c(2, 3, 4)]

# Define a new variable based on a selection - select a range of elements. Both values are inclusive
roulette_selection_vector <- roulette_vector[2:5]

# Select poker results for Monday, Tuesday and Wednesday - as the vectors have names, the names values can be used as well
poker_start <- poker_vector[c("Monday", "Tuesday", "Wednesday")]

# Calculate the average of the elements in poker_start
mean(poker_start)


##------------------------------------------------------------------------------
#' rpart Breaks
#'
#' Compute breaks for binning using rpart
#'
#'
#' @param fx formula to use for computing breaks
#' @param data the dataset to use to compute braks
#'
#' @author Vilhelm von Ehrenheim
#' @import rpart
#' @export
##------------------------------------------------------------------------------
rpart_breaks <- function(fx, data) {
        rp <- rpart(fx, data)
        out <- rp$splits[ ,"index"]
        names(out) <- NULL
        out
}


#!/usr/bin/Rscript
library(ggplot2)

candidates <- read.table("explore_generation_size.tsv",header = TRUE)

pdf("explore_generation_size_scatter.pdf")
ggplot(candidates, aes(x=generation, y=fitness) ) + geom_point() + facet_wrap( ~ Generation_size) +
  opts(title="Variation in performance for different generation sizes")
dev.off()

pdf("explore_generation_size_frontier.pdf")
frontier <- aggregate( . ~ Generation_size, data = candidates[,c("Generation_size","fitness")], max)
ggplot(frontier, aes(x=Generation_size, y=fitness) ) + geom_point() +
  opts(title="Variation in performance for different number of candidates per generation") +
  scale_x_continuous(name="Number of candidates in each generation") +
  scale_y_continuous(name="Fittest candidate after 20 generations")
dev.off()


library(ggplot2)
library(spatstat)
library(maptools)

to_ppp <- function(long,lat,win){
    as.ppp(ppp(long,lat,window=win))
}
load("afg.data")

afg <- afg.data
spatstat.options(checkpolygons = FALSE)
afg$data <- afg$data[!is.na(afg$data$Latitude),]

######## Everything above run before presentation

data = subset(afg$data, Type=="Friendly Fire" & DateOccurred > as.Date("2009-01-01"))
win = as(afg$outline,"owin")
points = to_ppp(data$Longitude, data$Latitude, win)
d = density(points,0.2)

img = t(as.matrix(d))
df = expand.grid(x=d$xcol, y=d$yrow)
df$z = melt(img)$value

p = ggplot(df, aes(x=x,y=y))
p + geom_tile(aes(fill=z))+theme_bw()


# Author: Jason Albino

## This code describes the steps taken to obtain average count of instances to create and to view reports of learners who have completed training and the average time elapsed
## between start of training and last usage of system, segmented by rank.

## Relevant data was only obtained from the 113 learners with known first days of training and last used dates

## Merge the first sheet of the Report Usage file with the training file. The 2 files were already read in and assigned variables

df2 <- df_usage
df1 <- df_training

my_data <- merge(df2, df1, by=c('UserId'), all.x = T)

names(my_data) <- c("UserId", "Create", "View", "Last_Day", "First_Day", "Course", "L1", "Rank", "Location", "Provider") ##Assign user-defined names

my_data$Last_Day <- round_date(my_data$Last_Day, unit = "day") 								## Strip time from date stamp
my_data$First_Day <- round_date(my_data$First_Day, unit = "day")							## Strip time from date stamp

my_data$Rank <- sapply(my_data$Rank, function(v) { if (is.character(v)) return(toupper(v)) else return(v)})		## Convert all ranks to uppercase

my_data$dateDiff <- my_data$Last_Day - my_data$First_Day								## Create column with time elapsed

## Calculate the mean instances for report creation and report viewing, by rank

reports <- c(2,3,8)													## Create vector of indices for subsetting

reportData <- my_data[, reports]											## Extract relevant columns from merged sheet

aggMean <- aggregate(reportData, by = list(my_data$Rank), FUN = mean)

## Calculate the mean time elapsed between start of training and last time used

dates <- c(8,11)													## Create vector of indices for subsetting

dateDiffData <- reportData[, dates]											## Extract relevant columns from merged sheet

aggDiffMean <- aggregate(dateDiffData, by = list(my_data$Rank), FUN = mean)

> aggMean
   Group.1    Create     View Rank
1      2LT  15.00000 122.0000   NA
2     CAPT  17.50000 115.0000   NA
3      CDR  11.00000  64.0000   NA
4      CIV        NA 161.0563   NA
5      CPL 116.00000 119.0000   NA
6     LCDR  13.50000 164.0000   NA
7     LCOL  15.20000 145.8000   NA
8    LT(N)  17.00000 188.0000   NA
9      MAJ        NA 245.5455   NA
10    MCPL  16.00000 250.0000   NA
11     MWO  13.66667 272.6667   NA
12      WO  43.00000 187.0000   NA

> aggDiffMean
   Group.1 Rank    dateDiff
1      2LT   NA   4.000000
2     CAPT   NA  25.666667
3      CDR   NA   3.000000
4      CIV   NA  50.098592
5      CPL   NA  60.000000
6     LCDR   NA 149.000000
7     LCOL   NA   4.000000
8    LT(N)   NA 163.000000
9      MAJ   NA  66.363636
10    MCPL   NA  53.666667
11     MWO   NA   6.666667
12      WO   NA 115.000000

## Add column with date the data was received

my_data$dateReceived <- as.POSIXct(rep("2019-05-28", nrow(my_data)))

my_data$daysSince <- my_data$dateReceived - my_data$Last_Day								## Calculate number of days since last use

## Calculate mean time between 28 May 2019 and last time used, by rank

recent <- c(8,13)													                              ## Create vector of indices
recentData <- my_data[, recent]											                  	## Extract columns
aggRecent <- aggregate(recentData, by = list(my_data$Rank), FUN = mean)
> aggRecent
   Group.1 Rank  daysSince
1      2LT   NA 200.16667
2     CAPT   NA 157.33333
3      CDR   NA 248.16667
4      CIV   NA 148.94131
5      CPL   NA  60.16667
6     LCDR   NA  90.16667
7     LCOL   NA 184.36667
8    LT(N)   NA  97.16667
9      MAJ   NA 110.71212
10    MCPL   NA 115.50000
11     MWO   NA 150.83333
12      WO   NA  61.16667

## This code locates users who have completed the training (n =113) with mean calculations performed by rank and by L1

> df3 <- df1$UserId
> df4 <- df2$UserId
> intersect(df3, df4)													## Users who have taken training
  [1] "User009" "User027" "User111" "User060" "User056" "User079" "User028" "User069" "User100" "User088" "User105"
 [12] "User075" "User029" "User030" "User032" "User005" "User013" "User062" "User047" "User071" "User001" "User091"
 [23] "User101" "User089" "User020" "User080" "User017" "User044" "User113" "User046" "User018" "User010" "User048"
 [34] "User059" "User033" "User092" "User034" "User002" "User057" "User012" "User081" "User036" "User107" "User016"
 [45] "User074" "User118" "User072" "User052" "User006" "User051" "User050" "User095" "User037" "User099" "User085"
 [56] "User076" "User065" "User058" "User014" "User022" "User093" "User073" "User109" "User011" "User003" "User004"
 [67] "User038" "User114" "User068" "User015" "User094" "User040" "User117" "User021" "User103" "User054" "User102"
 [78] "User104" "User119" "User115" "User007" "User049" "User116" "User070" "User024" "User055" "User082" "User031"
 [89] "User019" "User064" "User067" "User041" "User084" "User008" "User090" "User096" "User097" "User063" "User045"
[100] "User077" "User078" "User083" "User025" "User112" "User110" "User053" "User042" "User026" "User108" "User087"
[111] "User098" "User106" "User086"

## Number of unique users
df5 <- intersect(df3, df4)
> table(df5)
df5
User001 User002 User003 User004 User005 User006 User007 User008 User009 User010 User011 User012 User013 User014
      1       1       1       1       1       1       1       1       1       1       1       1       1       1
User015 User016 User017 User018 User019 User020 User021 User022 User024 User025 User026 User027 User028 User029
      1       1       1       1       1       1       1       1       1       1       1       1       1       1
User030 User031 User032 User033 User034 User036 User037 User038 User040 User041 User042 User044 User045 User046
      1       1       1       1       1       1       1       1       1       1       1       1       1       1
User047 User048 User049 User050 User051 User052 User053 User054 User055 User056 User057 User058 User059 User060
      1       1       1       1       1       1       1       1       1       1       1       1       1       1
User062 User063 User064 User065 User067 User068 User069 User070 User071 User072 User073 User074 User075 User076
      1       1       1       1       1       1       1       1       1       1       1       1       1       1
User077 User078 User079 User080 User081 User082 User083 User084 User085 User086 User087 User088 User089 User090
      1       1       1       1       1       1       1       1       1       1       1       1       1       1
User091 User092 User093 User094 User095 User096 User097 User098 User099 User100 User101 User102 User103 User104
      1       1       1       1       1       1       1       1       1       1       1       1       1       1
User105 User106 User107 User108 User109 User110 User111 User112 User113 User114 User115 User116 User117 User118
      1       1       1       1       1       1       1       1       1       1       1       1       1       1
User119
      1

> common <- my_data$UserId %in% df5
> df6 <- my_data[common, ]
> nrow(df6)
[1] 113

> sum(is.na(df6$Rank))
[1] 7

> table(df6$Rank)

  2LT  CAPT   CDR   CIV   CPL  LCDR  LCOL LT(N)   MAJ  MCPL   MWO    WO
    1     6     1    71     1     2     5     1    11     3     3     1

> reportData2 <- df6[, reports]
> aggCreate <- aggregate(reportData2, by=list(reportData2$Rank), FUN = mean)

aggCreate <- aggregate(reportData2, by=list(reportData2$Rank), FUN = mean, na.rm = T)
> aggCreate
   Group.1    Create     View Rank
1      2LT  15.00000 122.0000   NA
2     CAPT  17.50000 115.0000   NA
3      CDR  11.00000  64.0000   NA
4      CIV  17.24286 161.0563   NA
5      CPL 116.00000 119.0000   NA
6     LCDR  13.50000 164.0000   NA
7     LCOL  15.20000 145.8000   NA
8    LT(N)  17.00000 188.0000   NA
9      MAJ  26.11111 245.5455   NA
10    MCPL  16.00000 250.0000   NA
11     MWO  13.66667 272.6667   NA
12      WO  43.00000 187.0000   NA
> recentData2 <- df6[, recent]

> aggRecent2 <- aggregate(recentData2, by= list(reportData2$Rank), FUN = mean)

> aggRecent2
   Group.1 Rank  daysSince
1      2LT   NA 200.16667
2     CAPT   NA 157.33333
3      CDR   NA 248.16667
4      CIV   NA 148.94131
5      CPL   NA  60.16667
6     LCDR   NA  90.16667
7     LCOL   NA 184.36667
8    LT(N)   NA  97.16667
9      MAJ   NA 110.71212
10    MCPL   NA 115.50000
11     MWO   NA 150.83333
12      WO   NA  61.16667


\name{MSRL.cv}
\alias{MSRL.cv}
\title{Fit the multivariate square-root lasso.}
\usage{
MSRL.cv(X, Y, nlambda, lambda.vec = NULL,
    weighted = FALSE, standardize = FALSE, ADMM = FALSE, nfolds = NULL,
    delta = .01, tol = 1e-8, quiet = TRUE, inner.quiet=TRUE)
}
\arguments{

 \item{X}{An \eqn{n \times p} matrix of predictors (unstandardized).}
  \item{Y}{An \eqn{n \times q} matrix of responses (unstandardized).}
  \item{nlambda}{The number of candidate tuning parameters to be considered.}
  \item{lambda.vec}{A vector of positive tuning parameters to be considered (overriding internal candidate set). Should be in descending order.}
  \item{weighted}{Should the penalty be weighted by response variables' standard deviations?}
  \item{standardize}{Should predictors be standardized for model fitting?}
  \item{ADMM}{Determines whether the algorithm starts using ADMM or APG. By default, if \eqn{n > q}, will start with APG and move to ADMM when appropriate.}
  \item{nfolds}{Number of folds for cross-validation.}
  \item{delta}{Ratio of maximum to minimum candidate tuning parameters. }
  \item{tol}{Convergence tolerance parameter}
  \item{quiet}{Print progress?  }
  \item{quiet}{Print iteration-by-iteration progress? Should be used for diagnostics.}
}
\value{
 	\item{beta}{A sparse matrix with estimated regression coefficients. Use MSRL.coef or MSRL.predictor for coefficient extraction or prediction.}
	\item{sparsity.mat}{A matrix indicating the degree of sparsity at each estimated \eqn{\beta}}
	\item{err.pred}{A matrix of sum-of-squared prediction errors from cross-validation.}
	\item{err.wpred}{A matrix of weighted sum-of-squared prediction errors from cross-validation.}
	\item{err.spec}{A matrix of spectral norm prediction errors from cross-validation.}
	\item{err.nuc}{A matrix of nuclear norm prediction errors from cross-validation.}
	\item{Y.mean}{Means for the response variables; used by MSRL.coef and MSRL.predictor.}
	\item{X.mean}{Means for the predictor variables; used by MSRL.coef and MSRL.predictor.}
	\item{Y.sd}{Standard deviations for the response variables; used by MSRL.coef and MSRL.predictor.}
	\item{X.sd}{Standard deviations for the predictor variables; used by MSRL.coef and MSRL.predictor.}
	\item{lambda.vec}{A vector of the candidate tuning parameters}
	\item{lam.min}{The tuning parameter value which had the minimum cross-validation sum-of-squared prediction errors.}
	\item{standardize}{Were predictors standardized?}
         }

\description{
  A function for fitting the multivariate square-root lasso and performing cross-validation.
}


#!/usr/bin/env Rscript

state = c("tas", "qld", "sa", "sa",  "sa",  "vic",
        "nt", "act", "qld", "nsw", "wa", "nt", "wa",
        "nsw", "nsw", "vic", "vic", "vic", "nsw", "qld", "qld", "vic",
        "wa", "qld", "sa", "tas", "nsw", "nsw", "wa","act")

## 将向量分组(多个水平)
statef = factor(state)
statef
## 组(水平)
levels(statef)


myTestRule {
#Input parameters are:
#  Select field
#  Function to apply to attribue
#Input/Output parameter:
#  GenQuery structure
#Output from running the example is:
#  List of sizes of collections in /tempZone/home/rods

  # initial select is on COLL_NAME
  msiMakeGenQuery(*Select,"COLL_NAME like '/tempZone/home/rods/%%'",*GenQInp);

  # add select on sum(DATA_SIZE)
  msiAddSelectFieldToGenQuery(*SelectAdd,*Function,*GenQInp);
  msiExecGenQuery(*GenQInp,*GenQOut);
  foreach(*GenQOut)
  {
    msiGetValByKey(*GenQOut,"DATA_SIZE",*Size);
    msiGetValByKey(*GenQOut,"COLL_NAME",*Coll);
    writeLine("stdout","For collection *Coll, the size of the files is *Size");
  }
}
INPUT *Select="COLL_NAME", *SelectAdd="DATA_SIZE", *Function="SUM"
OUTPUT ruleExecOut


fn.ge = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_ge_matrix_gene_sle_lowDA.txt")
dat = fread(fn.ge, data.table = F) %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("gene") %>%
  data.matrix()

fn.si = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_sample_info_2_sle_lowDA.txt")
info = fread(fn.si)

info = info %>%
  mutate(SUBJECT = factor(SUBJECT, levels=
                            unique(SUBJECT[order(as.numeric(sub("SLE-","",SUBJECT)))])))

si = info$PG %in% c(5,6,7)
sum(si)
dat2 = dat[,si]
info2 = info[si,]

df = info2 %>%
  dplyr::select(SUBJECT) %>%
  bind_cols(as.data.frame(t(dat2))) %>%
  gather("gene","value",-SUBJECT) %>%
  group_by(SUBJECT, gene) %>%
  dplyr::summarise(mean=mean(value)) %>%
  ungroup()

df.mean = df %>%
  spread("SUBJECT","mean")

fn.out = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_lowDA_PG567_ge.mean_matrix.txt")
fwrite(df.mean, fn.out,
            sep="\t", row.names=F, col.names=T, quote=F)


library(ggplot2)

args <- commandArgs(TRUE)
file <- args[1]
outfile <- args[2]

data <- read.delim(file)

goodChrOrder <- paste("Chr", c(1:12), sep="")
data$CHROM <- factor(data$CHROM, levels=goodChrOrder)

# 获取显著性阈值
top5.value <- as.numeric(quantile(data$WEIGHTED_FST,prob=1-5/100))
top10.value <- as.numeric(quantile(data$WEIGHTED_FST,prob=1-10/100))

# 根据显著性阈值加标签
data$sig <- "nosig"
data[data$WEIGHTED_FST >= top10.value,]$sig <- "top10pct"
data[data$WEIGHTED_FST >= top5.value,]$sig <- "top5pct"

# 将标签列转换为factor属性
data$sig <- as.factor(data$sig)

pdf(outfile,width=20,height=4)
ggplot(data[data$WEIGHTED_FST > 0,], aes(x=BIN_START/1000000, y=WEIGHTED_FST, color=sig)) +
  geom_point(stat="identity", position="identity",size=0.5) +
  # 设定颜色
  scale_color_manual(values = c("grey", "orange", "red")) +
  facet_wrap(~ CHROM, ncol=12, scales = "free_x", strip.position = "bottom") +
  ggtitle("REF:MSU") +
  xlab("Position(Mb)") +
  ylab("value") +
  theme_bw() +
  theme(axis.line = element_line(colour = "black"),
        panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.border = element_blank(),
        panel.background = element_blank())
dev.off()


library(beanplot)
library('KernSmooth')
library('MASS')

# bhvdir = '/SCRATCH/BHV_files'
#
# bhvfl  = 'I_34_change_release_2014_06_02.dat'
# bhvfl  = 'I_34_chng_rel_2014_06_03.dat'
# bhvfl  = 'I_34_chng_rel_2014_06_04.dat'

RTbw = 25

fname  = file.choose()
bhvfl  = basename(fname)
bhvdir =  dirname(fname)

setwd(bhvdir)

dt=read.table(bhvfl, header=TRUE)

sesstime = (dt$GoEff - dt$GoEff[1])/60000

reltime   = dt$TPullEff - dt$TrialStart
relpos   = is.finite(reltime);
hitpos   = dt$Result == 0 & is.finite(dt$RT)

RThit    = density(dt$RT[hitpos], bw=RTbw, from=0, cut=0, na.rm=TRUE)
RThit$y  = RThit$y  * sum(hitpos)  * RTbw

x11(width=4, height=8, pointsize=10)

par(mfrow=c(2,1))

### reaction time distribution
max_X = tail(RThit$x, n=1)
max_Y = max(RThit$y)

truehist(dt$RT, h=RTbw, col='darkgrey', main='Reaction Time', xlab='RT [ms]', ylab='count', prob=FALSE, xlim=c(0, max_X), xaxs='i', yaxs='i')
lines(RThit,  lwd=2.5, col='red')
abline(v=median(dt$RT, na.rm=TRUE), col='red', lwd=2.5)

text(max_X, max_Y,pos=2,adj=0,labels=paste('N(hit): ',sum(hitpos), sep=''),cex=1.2)

### session time course of reaction times
plot(sesstime[hitpos], dt$RT[hitpos], type='p', pch=20, ylab='RT [ms]', xlab='session time [min]', main='reaction times', xaxs='i', yaxs='i')
abline(h=median(dt$RT, na.rm=TRUE), col='red', lwd=2.,lty=2)

### save figure as image file
dev.copy(png,filename=paste(dt$Subject[1], '_',dt$Experiment[1],"_", dt$Date[1],'.png', sep=''),height=800, width=400, bg="white")
dev.off()


#' howmany
#'
#' How many rows/columns of a matrix can be stored for a given memory size.
#'
#' @details
#' This function provides the maximum dimension of an unallocated, dense,
#' in-core, numeric matrix of known byte size. For example, it will show the
#' largest possible square matrix which is 16 GiB (46340x46340).
#'
#' If the both \code{nrow} and \code{ncol} are missing (blank inputs), then the
#' largest square matrix will be returned.  If one of \code{nrow} or
#' \code{ncol} is supplied and the other is missing, then the non-supplied
#' argument (\code{nrow} or \code{ncol}) will be determined according to the
#' supplied one.  If both arguments are supplied, an error is produced --- you
#' probably meant to use \code{howmany()}.
#'
#' If \code{out.type="approximate"}, then a reduced representation of the
#' dimensions will be returned.  For example, the reduced representation of the
#' number 1234567890 would be "1.2b", since this number is basically 1.2
#' billion.  Not super useful, but kind of cute, and it arguably enhances
#' readability when fishing for a ballpark figure.
#'
#' @param x
#' The size of a matrix stored as a \code{memuse} class object.
#' @param nrow,ncol
#' Number of (global) rows/columns of the matrix.
#' @param out.type
#' If the full dimensions or a reduced representation should be
#' returned (see Details section below). Options are "full" and "approximate"
#' (with partial matching).
#' @param representation
#' The kind of storage the object would be in, i.e.
#' "dense" or "sparse".
#' @param names
#' string; control for whether the unit names should be
#' printed out or their abbreviation should be used.  Options are "long" and
#' "short", respectively.  Case is ignored.
#' @param ...
#' Additional arguments.
#' @param sparsity
#' The proportion of sparsity of the matrix if
#' \code{representation="sparse"}
#' @param type
#' "double" or "int"; the storage type of the data matrix.  If you
#' don't know the type, it is probably stored as a double, so the default value
#' will suffice.
#' @param intsize
#' The size (in bytes) of an integer.  Default is 4, but this is
#' platform dependent.
#'
#' @return
#' A numeric pair, the dimensions of a matrix.
#'
#' @examples
#' \dontrun{
#' x <- mu(1, "gib")
#'
#' # largest square matrix that's 1 GiB
#' howmany(x)
#' # same, but ballpark figure
#' howmany(mu(1, "gib"), out.type="approx")
#' }
#'
#' @seealso \code{\link{howbig}}
#' @keywords Methods
#' @export
howmany <- function(x, nrow, ncol, out.type="full", representation="dense", ..., sparsity=0.05, type="double", intsize=4, names="short")
{
  if (class(x) != "memuse")
    stop("input 'x' must be a memuse class object")

  # Manage input arguments
  out.type <- match.arg(arg=tolower(out.type), choices=c("full", "approximate"))
  representation <- match.arg(tolower(representation), c("dense", "sparse"))
  type <- match.arg(arg=tolower(type), choices=c("double", "integer"))

  bytes <- check_type(type=type, intsize=intsize)

  # Get the size
  size <- convert_to_bytes(x)@size

  if (!missing(nrow)){
    if (!is.int(nrow))
      stop("argument 'nrow' must be an integer")
    else if (!missing(ncol))
      stop("you should supply at most one of 'nrow' and 'ncol'.  Perhaps you meant to use howbig()?")
    else
      ncol <- floor(size/(nrow*bytes))
  }
  else if (!missing(ncol)){
    if (!is.int(ncol))
      stop("argument 'ncol' must be an integer")
    nrow <- floor(size/(ncol*bytes))
  }
  else
    nrow <- ncol <- floor(sqrt(size/bytes))

  # Return
  ret <- c(nrow, ncol)

  if (out.type == "approximate")
    ret <- hr(ret, names=names)

  ret
}


# Working with OOP
# S3 and R6 are OOP frameworks related to R. Each of them relate to historic programming concepts for R

# A. What is it?
# 1. Dealing with objects
# Create these variables
a_numeric_vector <- rlnorm(50)
a_factor <- factor(
  sample(c(LETTERS[1:5], NA), 50, replace = TRUE)
)
a_data_frame <- data.frame(
  n = a_numeric_vector,
  f = a_factor
)
a_linear_model <- lm(dist ~ speed, cars)

# Call summary() on the numeric vector
summary(a_numeric_vector)

# Do the same for the other three objects
summary(a_factor)
summary(a_data_frame)
summary(a_linear_model)

# B. How does R distinguish variables?
# 1. What's my type
# function created to review the four functions that help to understand what type of variable that we are working with
type_of <- function(x)
{
  c(
    class = class(x),
    typeof = typeof(x),
    mode = mode(x),
    storage.mode = storage.mode(x)
  )
}

# Look at the definition of type_info()
type_info

# Create list of example variables. Note that most functions that are used will be closure type
some_vars <- list(
  an_integer_vector = rpois(24, lambda = 5),
  a_numeric_vector = rbeta(24, shape1 = 1, shape2 = 1),
  an_integer_array = array(rbinom(24, size = 8, prob = 0.5), dim = c(2, 3, 4)),
  a_numeric_array = array(rweibull(24, shape = 1, scale = 1), dim = c(2, 3, 4)),
  a_data_frame = data.frame(int = rgeom(24, prob = 0.5), num = runif(24)),
  a_factor = factor(month.abb),
  a_formula = y ~ x,
  a_closure_function = mean,
  a_builtin_function = length,
  a_special_function = `if`
)

# Loop over some_vars calling type_info() on each element to explore them
lapply(some_vars, type_info)

# C. Assigning classes
# 1. Make if classy
# Explore the structure of chess
str(chess)

# Override the class of chess
class(chess) <- "chess_game"

# Is chess still a list? Yes the implicit type will stay the same
is.list(chess)

# How many pieces are left on the board?
length(unlist(chess))


library("beanplot")
hoge <- read.csv("synthesized_info.csv")
dead <- subset(hoge, status == "dead")
arrive <- subset(hoge, status == "arrive")
beanplot(dead$co.evolution.rate, arrive$co.evolution.rate, names=c("dead test code", "arrive test code"), ylab="degree of co-eovlution")
beanplot(dead$lifetime, arrive$lifetime, names=c("dead test code", "arrive test code"), ylab="lifetime")


# setting directory
#setwd("~/Desktop/projects/r-projects")

#clean environment memory in R
rm(list = ls())

#import data
sample <- read.csv("sample.csv", header = FALSE)

#if it was a table in txt..
#sample <- read.table("sample.txt", sep=",", header = FALSE)

#assess data
summary(sample)
nrow(sample)
head(sample)
tail(sample)
str(sample) #show structure of R object
dim(sample) #dimensions

#counting
max(sample$V4)
min(sample$V5)
unique(sample$V2)
sort(unique(sample$V2))
length(unique(sample$V2))

#queries
which(sample$V3 == "Eugene Barchas")
length(which(sample$V3 == "Eugene Barchas"))

#check data type
is.matrix(sample)
is.data.frame(sample)

#manipulate data
sample_mtx <- as.matrix(sample)
is.matrix(sample_mtx)

a <- matrix(1,2,3)
a
is.matrix(a)
as.data.frame(a)

#transpose
t(a)
a

#delete/add a row/columns
a <- a[-1,]
a
a <- rbind(a, c(2,2,2)) #add row
a
a <- cbind(a, c(2,3)) #add col
a


library(ewaff)
options(mc.cores=4)

source("simulation-functions.r")
library(simsurv)

###################################
## construct a random dataset with
## a single CpG site association
set.seed(20180220)

n <- 100 ## n samples
s <- 1000  ## s features

## generate survival data correlated with random methylation pattern
data <- data.frame(binvar=sample(c("A","B"), n, replace=T),
                   convar=rnorm(n),
                   methylation=runif(n))
data <- cbind(data,
              simsurv(lambdas=0.1,
                      gammas=1.5,
                      betas=c(methylation = 2),
                      x=data)[,-1])

manifest <- data.frame(chr=c(rep(1,s/2), rep(2,s/2)), pos=sample(1:(150*s), s))
manifest <- manifest[order(manifest$chr, manifest$pos),]

methylation <- generate.methylation(n, manifest$pos)
rownames(methylation) <- paste("cpg", 1:nrow(methylation), sep="")

## insert the survival correlated methylation pattern
## at the location of the random CpG site most strongly
## correlated with the methylation pattern
r <- abs(cor(t(methylation), data$methylation))
methylation[which.max(r),] <- data$methylation

data$methylation <- NULL

############################
## add some missing values

methylation[sample(1:length(methylation), 5)] <- NA

data$binvar[sample(1:nrow(data), 3)] <- NA

###################################
## test associations at each CpG site
sites.ret <- ewaff.sites(Surv(eventtime, status) ~ methylation + binvar + convar,
                         methylation=methylation,
                         data=data,
                         generate.confounders="pca",
                         n.confounders=5,
                         random.subset=0.5,
                         method="coxph")

##########################
## generate report
sum.ret <- ewaff.summary(sites.ret, manifest$chr, manifest$pos, methylation,
                         selected.cpg.sites=paste("cpg", which.max(r)+ -5:5, sep=""))

ewaff.report(sum.ret, output.file="output/coxph.html",
             author="Gloria Gaynor",
             study="Surviving stuff")


#'@title calcKristCaa
#'
#'@description Calculate air resistance (\code{Caa}) (dimensionless) using the
#'Kristensen method.
#'
#'@param shipType Ship type (vector of strings, see \code{\link{calcShipType}}).
#'Must align with \code{tankerBulkCarrierGCargoShipTypes} and
#' \code{containerShipTypes} groupings
#'@param dwt Ship maximum deadweight tonnage (vector of numericals, tonnage)
#'@param tankerBulkCarrierGCargoShipTypes Ship types specified in input
#'\code{shipTypes} to be modeled as tankers, bulk carriers and general cargo
#'vessels (vector of strings)
#'@param containerShipTypes Ship types specified in input \code{shipTypes} to be
#'modeled as container ships (vector of strings)
#'
#' @details
#' Models the effect of realistic hull roughness on resistance, which is not
#' captured in the frictional and residual resistance coefficients from tank
#' towing operations.
#'
#' This method this requires ship types to be grouped. Use the
#' \code{tankerBulkCarrierGCargoShipTypes}, \code{containerShipTypes} grouping
#' parameters to provide these ship type groupings. Any ship types not included
#' in these groupings will be considered as miscellaneous vessels.
#'
#' NOTE: within the container ship section of this calculation, estimations are
#' made of the ships TEU:\itemize{
#' \item Feeder: TEU = ((dwt/15.19)^(1/0.9814))
#' \item Panamax: TEU = ((dwt/28.81)^(1/0.902))
#' \item PostPanamax: TEU = ((dwt/37)^(1/0.875))
#' }
#' These come from: H.O. Kristensen (2016), "Revision of statistical analysis and determination of
#' regression formulas for main dimensions of container ships based on data from Clarkson".
#' Kristensen's SHIP DESMO model also uses another dwt/teu relation for post-panamax container ships
#' with breadth > 49m. This equation has no inverse to map dwt to TEU and thus all post panamaxs are
#' assumed to have the same dwt/teu relation for all breadths, described above.
#'
#' @return \code{Caa} (vector of numericals, dimensionless)
#'
#' @references
#'Kristensen, H. O. and Lutzen, M. 2013. "Prediction of Resistance and Propulsion
#'Power of Ships."
#'
#'Kristensen, H. O. 2016. "Revision of statistical analysis and determination of
#'regression formulas for main dimensions of container ships based on data from
#'Clarkson."
#'
#'\href{https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}{Kristensen, H. O.
#'"Ship-Desmo-Tool." https://gitlab.gbar.dtu.dk/oceanwave3d/Ship-Desmo}
#'
#'@family Kristensen Calculations
#'@family Resistance Calculations
#'
#' @examples
#' calcKristCaa(c("bulk.carrier","container.ship","other.tanker"),c(70000,191144,20000))
#' calcKristCaa(c("bulk.carrier","container.ship","other.tanker"),c(70000,191144,20000),
#'              tankerBulkCarrierGCargoShipTypes=c("bulk.carrier","other.tanker"))
#'
#' @export

calcKristCaa<-function(shipType,dwt,
                       tankerBulkCarrierGCargoShipTypes=c("tanker","general.cargo","chemical.tanker","liquified.gas.tanker","oil.tanker","other.tanker","bulk.carrier"),
                       containerShipTypes=c("container.ship")
){
  Caa<- ifelse(shipType%in%tankerBulkCarrierGCargoShipTypes,
               ifelse(#case 1:"Small","Handysize","Handymax",
                 dwt <= 55000,0.07,
                 ifelse(#case 2:"Panamax","Aframax","Suezmax"
                   dwt <= 200000,0.05,
                   #case 3: "VLCC","VLBC"
                   0.04
                 )#end case 3
               )# end case 2
               # end case 1
  #end non container ship group
  ,ifelse(shipType %in% containerShipTypes,#start container ship group
  ifelse( #case 1 Feeder
    dwt <= 35000, pmax(0.28*((dwt/15.19)^(1/0.9814))^-0.126,0.09),
    ifelse(#case 2 Panamax
      dwt <= 60000, pmax(0.28*((dwt/28.81)^(1/0.902))^-0.126,0.09),
      pmax(0.28*((dwt/37)^(1/0.875))^-0.126,0.09) #PostPanamax
    )# end case 2
  ),
  NA# end case 1
  #end container ship group
                            )
  )

  return(Caa/1000)
}


library(reshape)

# get the features file. This should become an amcat call at some point!
# expects columns aid, lemma, pos, and n
f = read.csv("~/features_perart.csv")

# What are the most frequent lemmata?
words = aggregate(f$n, list(f$lemma), FUN=sum)
colnames(words) = c("word", "n")
words = words[order(-words$n), ]

# What are the most frequent nouns?
words = with(f[f$pos == 'N',], aggregate(n, list(lemma), FUN=sum))
colnames(words) = c("word", "n")
words = words[order(-words$n), ]

# compare articles with 'crimi' to articles without
c = corpus.split(f$aid, f$lemma, f$n, 'crimi')
r = corpus.compare(c$words.x, c$freq.x, c$words.y, c$freq.y)

r = r[r$freq.x > 10, ]
r = r[order(-r$chi), ]

# feature selection for lda
f2 = f[f$aid %in% f$aid[grepl('crimi', f$lemma)], ]
words = corpus.freqs(f2$aid, f2$lemma, f2$n)
words = merge(words, r, all.x=T)
words = words[words$tf > 5 &  words$over > 1 & words$chi > 10, ]
words = words[words$df.prop < .25 | words$chi > 100, ]

# do lda (requires lda_lib)
features = f2[f2$lemma %in% words$word,]
ldamatrix = lda.create.matrix(match(features$lemma, words$word), features$n, features$aid)
m = lda.cluster(ldamatrix, words$word, nclusters=30, niterations=100)

View(top.topic.words(m$topics))


library('DMwR')
dataset=read.csv("H:\\kdd_cup1.csv")
dataset=dataset[1:100,]
outlier.scores<-lofactor(dataset,5)
plot(density(log(outlier.scores)))
outliers<-order(outliers.scores,decreasing=T)[1:5]
print(outliers)
n<-nrow(dataset)
labels<-1:n
labels[-outliers]<-"."
biplot(prcomp(dataset),cex=1.2 xlabs=labels)
pch<-rep(".",n)
pch[outliers]<-"+"
col<-rep("black",n)
col[outliers]<-"red"
pairs(dataset,pch=pch,col=col)


#' Compute metacell using a native implementation of a graph cover k-means-like approach
#'
#' @param mc_id id of metacell object to be added
#' @param graph_id a knn graph object id into scdb
#' @param mat_id a matrix object id
#' @param min_mc_size target minimum metacell size. This is only an approximation and smaller MC may be returned by the algorithm
#'

mcell_add_mc_from_graph = function(mc_id, graph_id, mat_id, min_mc_size)
{
    old_seed = .set_seed(get_param("mc_rseed"))

	tgs_clust_cool = get_param("scm_tgs_clust_cool")
	tgs_clust_burn = get_param("scm_tgs_clust_burn_in")

	graph = scdb_cgraph(graph_id)
	if(is.null(graph)) {
		stop("MC-ERR: cell graph id ", graph_id, " is missing when running add_mc_from_graph")
	}
	mat = scdb_mat(mat_id)
	if(is.null(mat)) {
		stop("MC-ERR: mat id ", mat_id, " is missing when running add_mc_from_graph")
	}
	message("running graph clustering now - one iteration no bootstrap")
	edges = graph@edges
	colnames(edges) = c("col1", "col2", "weight")
	node_clust = tgs_graph_cover(edges, min_mc_size, cooling = tgs_clust_cool, burn_in = tgs_clust_burn)
	f_outlier = (node_clust$cluster == 0)

	outliers = colnames(mat@mat)[node_clust$node[f_outlier]]
	mc = as.integer(as.factor(node_clust$cluster[!f_outlier]))
	names(mc) = colnames(mat@mat)[!f_outlier]
	message("building metacell object, #mc ", max(mc))
	cell_names = colnames(mat@mat)
	scdb_add_mc(mc_id, tgMCCov(mc, outliers, mat))
	message("reordering metacells by hclust and most variable two markers")

	.restore_seed(old_seed)

	mcell_mc_reorder_hc(mc_id)
}


#!/usr/bin/Rscript

## contour-MA.r -- converts a delta summary file into a Minor
## Allele Frequency contour graph.

## Author: David Eccles (gringer), 2014 <bioinformatics@gringene.org>

usage <- function(){
  cat("usage: ./contour_MA.r <file>\n");
}

fileName <- "data/stats_HBM30_CEU90_lowMAFfiltered.txt.gz";

if(length(commandArgs(TRUE)) > 0){
    fileName <- commandArgs(TRUE)[1];
}
inFile <- gzfile(fileName);
open(inFile);
cat("Reading in file...", file = stderr());
table.delta <- read.table(inFile, header = TRUE, row.names = 1);
close(inFile);
cat("done!\n", file = stderr());

popNames <- gsub(".","",sub("^p.AA?.","",colnames(table.delta)[grep("^p.AA?",colnames(table.delta))]), fixed = TRUE);
popNames <- unique(popNames);
cat("Populations:",popNames,"\n");
cat("Column names:",colnames(table.delta),"\n");

cat("Calculating prior statistics...", file = stderr());
cat(" mean allele frequencies...", file = stderr());
if(length(grep("^p.AC",colnames(table.delta))) > 0){
  # contains genotype rather than allele counts
  table.delta$meanA <- rowMeans(table.delta[,paste("p.AA.",popNames,".",sep="")] + table.delta[,paste("p.AC.",popNames,".",sep="")] / 2);
  table.delta$meanC <- rowMeans(table.delta[,paste("p.CC.",popNames,".",sep="")] + table.delta[,paste("p.AC.",popNames,".",sep="")] / 2);
  table.delta$meanBoth <- table.delta$meanA + table.delta$meanC;
} else {
  table.delta$meanA <- rowMeans(table.delta[,paste("p.A.",popNames,".",sep="")]);
  table.delta$meanC <- rowMeans(table.delta[,paste("p.C.",popNames,".",sep="")]);
  table.delta$meanBoth <- table.delta$meanA + table.delta$meanC;
}

cat(" minor allele...", file = stderr());
table.delta$mAllele <- c("A","C")[2 - (table.delta$meanA < table.delta$meanC)];

cat(" minor allele frequencies...", file = stderr());
table.delta[,paste("MAF.",popNames,".",sep="")] <- NA;
if(length(grep("^p.AC",colnames(table.delta))) > 0){
  table.delta[table.delta$mAllele == "A",paste("MAF.",popNames,".",sep="")] <-
      (table.delta[table.delta$mAllele == "A",
                   paste("p.AA.",popNames,".",sep="")] +
     table.delta[table.delta$mAllele == "A",
                 paste("p.AC.",popNames,".",sep="")]/2);
  table.delta[table.delta$mAllele == "C",
              paste("MAF.",popNames,".",sep="")] <-
    (table.delta[table.delta$mAllele == "C",
                 paste("p.CC.",popNames,".",sep="")] +
     table.delta[table.delta$mAllele == "C",
                 paste("p.AC.",popNames,".",sep="")]/2);
} else {
    table.delta[,paste("MAF.",popNames,".",sep="")] <- NA;
    table.delta[table.delta$mAllele == "A",
                paste("MAF.",popNames,".",sep="")] <-
                    table.delta[table.delta$mAllele == "A",
                                paste("p.A.",popNames,".",sep="")];
    table.delta[table.delta$mAllele == "C",
                paste("MAF.",popNames,".",sep="")] <-
                    table.delta[table.delta$mAllele == "C",
                                paste("p.C.",popNames,".",sep="")];
}
flipRows <- table.delta[,paste("MAF.",popNames[1],".",sep="")] > 0.5;
table.delta[flipRows,paste("MAF.",popNames,".",sep="")] <-
    1 - table.delta[flipRows,paste("MAF.",popNames,".",sep="")];
cat("done!\n", file = stderr());

head(table.delta);

## table.delta <- table.delta[,c(paste("MAF.",popNames,".",sep=""),"missing","mAllele")];

cat("Producing graph...", file = stderr());

pdf(paste("contour_MAF_",paste(popNames, collapse = "_"),".pdf",sep=""));
makeContour <- function(){
    par(mar = c(5,5,1,1));
    smoothScatter(table.delta[,paste("MAF.",popNames[1],".",sep="")],
                  table.delta[,paste("MAF.",popNames[2],".",sep="")],
                  colramp = colorRampPalette(c("red","orange","yellow",
                      "green","cyan","blue","violet")),
                  transformation = function(x){log(pmax(1,x))/log(10)},
                  nrpoints = 0, xlab = paste("MAF(",popNames[1],")",sep=""),
                  ylab = paste("AF(",popNames[2],")",sep=""),
                  xlim = range(table.delta[,paste("MAF.",popNames[1],".",sep="")]),
                  ylim = range(table.delta[,paste("MAF.",popNames[2],".",sep="")]),
                  xaxs = "i", yaxs = "i",
                  las = 1, cex.lab = 1.5);
    abline(0,1,lty = "dotted", lwd = 3);
}
makeContour();
dummy <- dev.off();
cat("done!\n", file = stderr());

#pdf(paste("contour_MAF_",paste(popNames, collapse = "_"),".pdf",sep=""))
#for(x in 1:(length(popNames) - 1)){
#  for(y in (x+1):length(popNames)){
#    pop1Str <- paste("MAF.",popNames[x],".",sep="");
#    pop2Str <- paste("MAF.",popNames[y],".",sep="");
#    hb <- hexbin(table.delta[,pop1Str],table.delta[,pop2Str], xbins = 60);
#    hb@xlab <- popNames[x];
#    hb@ylab <- popNames[y];
#    plot(hb, trans = function(x){log(pmax(1,x))/log(10)}, inv = function(x){10^x},
#         colramp = colorRampPalette(c("blue","green","yellow","orange","red")),
#         mincnt = 0);
#  }
#}
#dummy <- dev.off();
#cat("done!\n", file = stderr());