library(forecast)
library(plyr)
library(zoo)

MAX_DECIMAL <- 79228162514264337593543950335

#Time series models
TIME_SERIES_MODEL_ALL = "ALL"
TIME_SERIES_MODEL_ARIMA = "ARIMA"
TIME_SERIES_MODEL_ETS = "ETS"
TIME_SERIES_MODEL_STL = "STL"
TIME_SERIES_MODEL_ETS_ARIMA = "ETS+ARIMA"
TIME_SERIES_MODEL_ETS_STL = "ETS+STL"

TIME_SERIES_MODELS = c(TIME_SERIES_MODEL_ALL, TIME_SERIES_MODEL_ARIMA, TIME_SERIES_MODEL_ETS, TIME_SERIES_MODEL_STL, TIME_SERIES_MODEL_ETS_ARIMA, TIME_SERIES_MODEL_ETS_STL)

#Missing value substitution options
MISSING_VALUE_MEAN = "MEAN"
MISSING_VALUE_PREVIOUS = "PREVIOUS"
MISSING_VALUE_INTERPOLATION_LINEAR = "INTERPOLATE LINEAR"
MISSING_VALUE_INTERPOLATION_POLYNOMIAL = "INTERPOLATE POLYNOMIAL"

MISSING_VALUE_OPTIONS = c(MISSING_VALUE_MEAN, MISSING_VALUE_PREVIOUS, MISSING_VALUE_INTERPOLATION_LINEAR, MISSING_VALUE_INTERPOLATION_POLYNOMIAL)

#Values for the FORCE_SEASONALITY
FORCE_SEASONALITY_AUTO = "AUTO"
FORCE_SEASONALITY_NONE = "NONE"
FORCE_SEASONALITY_ADDITIVE = "ADDITIVE"
FORCE_SEASONALITY_MULTIPLICATIVE = "MULTIPLICATIVE"

FORCE_SEASONALITY_OPTIONS = c(FORCE_SEASONALITY_AUTO, FORCE_SEASONALITY_NONE, FORCE_SEASONALITY_ADDITIVE, FORCE_SEASONALITY_MULTIPLICATIVE)

#Values for the MISSING_VALUE_SCOPE option
MISSING_VALUE_SCOPE_GLOBAL = "GLOBAL"
MISSING_VALUE_SCOPE_GRANULARITY_ATTRIBUTE = "GRANULARITY_ATTRIBUTE"
MISSING_VALUE_SCOPE_HISTORY_DATE_RANGE = "HISTORY_DATE_RANGE"

MISSING_VALUE_SCOPE_OPTIONS = c(MISSING_VALUE_SCOPE_GLOBAL, MISSING_VALUE_SCOPE_GRANULARITY_ATTRIBUTE, MISSING_VALUE_SCOPE_HISTORY_DATE_RANGE)

order_and_fill_missing_values <- function(data, missingValueSubstitution, min_datekey, max_datekey) {

    #Order data by date key
    data <- data[order(data$DATEKEY),]

    #Get minimum and maximum date keys
    if (is.na(min_datekey)) {
        min_datekey <- head(data$DATEKEY, 1)
    }
    if (is.na(max_datekey)) {
        max_datekey <- tail(data$DATEKEY, 1)
    }

    #Fill records with missing date keys with NaN
    filled_data <- merge(data.frame(list(DATEKEY = seq(min_datekey, max_datekey))), data, all = T)

    #Replace NaN with a value, so forecast models knows that there was no data.
    if (is.numeric(missingValueSubstitution)) {
        filled_data$TRANSACTIONQTY[is.na(filled_data$TRANSACTIONQTY)] <- missingValueSubstitution
    }
    else if (missingValueSubstitution == MISSING_VALUE_MEAN) {
        filled_data$TRANSACTIONQTY[is.na(filled_data$TRANSACTIONQTY)] <- mean(filled_data$TRANSACTIONQTY, na.rm = TRUE)
    }
    else if (missingValueSubstitution == MISSING_VALUE_PREVIOUS) {
        filled_data$TRANSACTIONQTY <- na.locf(filled_data$TRANSACTIONQTY, na.rm = FALSE)
    }
    else if (missingValueSubstitution == MISSING_VALUE_INTERPOLATION_LINEAR) {
        filled_data$TRANSACTIONQTY <- na.approx(filled_data$TRANSACTIONQTY, na.rm = FALSE)
    }
    else if (missingValueSubstitution == MISSING_VALUE_INTERPOLATION_POLYNOMIAL) {
        filled_data$TRANSACTIONQTY <- na.spline(filled_data$TRANSACTIONQTY)
    }

    return(filled_data)
}

mape <- function(observed, predicted) {

    observedLenght <- length(observed);

    if (observedLenght == 0) {
        return(-1);
    }

    #The same number of predicted and observed elements must be used
    predicted <- head(predicted, n = observedLenght);

    ape <- (abs(observed - predicted)) / observed * 100;
    mape <- mean(ape, na.rm = TRUE)

    if (is.nan(mape)) {
        mape <- -1;
    }

    return(mape);
}

modelArima <- function(historicalData, forecastHorizon, confidenceLevel, forceSeasonality) {
    return(tryCatch({
        force_seasonality_model_map <- c(NA, 1, 1, 0)
        names(force_seasonality_model_map) <- c(FORCE_SEASONALITY_AUTO, FORCE_SEASONALITY_ADDITIVE, FORCE_SEASONALITY_MULTIPLICATIVE, FORCE_SEASONALITY_NONE)

        arima_model <- auto.arima(historicalData, D = force_seasonality_model_map[forceSeasonality])
        fcast <- forecast(arima_model, h = forecastHorizon, level = c(confidenceLevel))

        mean_arima <- as.numeric(fcast$mean)
        sigma_arima <- as.numeric((fcast$upper - fcast$lower) / 2)
        arima_fitted <- as.numeric(fitted(arima_model))

        return(list(mean = mean_arima, sigma = sigma_arima, fitted = arima_fitted))

    }, error = function(err) {
        print(paste("ARIMA model error:  ", err))
        return(NULL)
    }))
}

modelEts <- function(historicalData, forecastHorizon, confidenceLevel, forceSeasonality) {
    return(tryCatch({
        # model = 3 characters: Z means automatically selected
        # 1st letter is error type, 2nd letter is trend type, 3rd letter is season type.
        force_seasonality_model_map <- c("ZZZ", "ZZA", "ZZM", "ZZN")
        names(force_seasonality_model_map) <- c(FORCE_SEASONALITY_AUTO, FORCE_SEASONALITY_ADDITIVE, FORCE_SEASONALITY_MULTIPLICATIVE, FORCE_SEASONALITY_NONE)

        ets_model <- ets(historicalData, model = force_seasonality_model_map[forceSeasonality])
        fcast <- forecast(ets_model, h = forecastHorizon, level = c(confidenceLevel))

        mean_ets <- as.numeric(fcast$mean)
        sigma_ets <- as.numeric((fcast$upper - fcast$lower) / 2)
        ets_fitted <- as.numeric(fitted(ets_model))

        return(list(mean = mean_ets, sigma = sigma_ets, fitted = ets_fitted))
    }, error = function(err) {
        print(paste("ETS model error:  ", err))
        return(NULL)
    }))
}

modelStl <- function(historicalData, forecastHorizon, confidenceLevel, seasonality) {
    if ((seasonality > 1) && (length(historicalData) > 2 * seasonality)) {
        tryCatch({
            fcast <- stlf(historicalData, h = forecastHorizon, level = c(confidenceLevel))

            mean_stl <- as.numeric(fcast$mean)
            sigma_stl <- as.numeric((fcast$upper - fcast$lower) / 2)
            stl_fitted <- as.numeric(fitted(fcast))

            return(list(mean = mean_stl, sigma = sigma_stl, fitted = stl_fitted))
        }, error = function(err) {
            print(paste("STL model error:  ", err))
            return(NULL)
        })
    }
    else {
        return(NULL)
    }
}

modelEtsArima <- function(ets_result, arima_result) {
    if (!is.null(ets_result) && !is.null(arima_result)) {
        mean_ets_arima <- (arima_result$mean + ets_result$mean) / 2.0;
        sigma_ets_arima <- sqrt(0.25 * ets_result$sigma * ets_result$sigma + 0.25 * arima_result$sigma * arima_result$sigma)
        ets_arima_fitted <- (arima_result$fitted + ets_result$fitted) / 2.0;

        return(list(mean = mean_ets_arima, sigma = sigma_ets_arima, fitted = ets_arima_fitted))
    }
    return(NULL)
}

modelEtsStl <- function(ets_result, stl_result) {
    if (!is.null(ets_result) && !is.null(stl_result)) {
        mean_ets_stl <- (stl_result$mean + ets_result$mean) / 2.0;
        sigma_ets_stl <- sqrt(0.25 * ets_result$sigma * ets_result$sigma + 0.25 * stl_result$sigma * stl_result$sigma)

        ets_stl_fitted <- (stl_result$fitted + ets_result$fitted) / 2.0;

        return(list(mean = mean_ets_stl, sigma = sigma_ets_stl, fitted = ets_stl_fitted))
    }
    return(NULL)
}

addToOutput <- function(vars_data_frame, granularity_attribute, date_key, transaction_qty, sigma, error_percentage, forecast_model_name) {
    new_data_frame <- data.frame(GRANULARITYATTRIBUTE = granularity_attribute, DATEKEY = date_key, TRANSACTIONQTY = transaction_qty, SIGMA = sigma, ERRORPERCENTAGE = as.numeric(0), FORECASTMODELNAME = "")

    # Put model parameters only in first line for same granularity attribute
    new_data_frame$ERRORPERCENTAGE[1] = error_percentage[1]
    new_data_frame$FORECASTMODELNAME[1] = forecast_model_name[1]

    return(rbind(vars_data_frame, new_data_frame));
}

trainModels <- function(timeSeriesModel, historicalData, forecastHorizon, confidenceLevel, seasonality, forceSeasonality) {
    result = list()

    #ARIMA
    if (timeSeriesModel == TIME_SERIES_MODEL_ARIMA || timeSeriesModel == TIME_SERIES_MODEL_ETS_ARIMA || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
        arimaForecast <- modelArima(historicalData, forecastHorizon, confidenceLevel, forceSeasonality)

        if (timeSeriesModel == TIME_SERIES_MODEL_ARIMA || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
            result[[TIME_SERIES_MODEL_ARIMA]] <- arimaForecast
        }
    }

    #ETS
    if (timeSeriesModel == TIME_SERIES_MODEL_ETS || timeSeriesModel == TIME_SERIES_MODEL_ETS_ARIMA || timeSeriesModel == TIME_SERIES_MODEL_ETS_STL || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
        etsForecast <- modelEts(historicalData, forecastHorizon, confidenceLevel, forceSeasonality)

        if (timeSeriesModel == TIME_SERIES_MODEL_ETS || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
            result[[TIME_SERIES_MODEL_ETS]] <- etsForecast
        }
    }

    #STL
    if (timeSeriesModel == TIME_SERIES_MODEL_STL || timeSeriesModel == TIME_SERIES_MODEL_ETS_STL || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
        stlForecast <- modelStl(historicalData, forecastHorizon, confidenceLevel, seasonality)

        if (timeSeriesModel == TIME_SERIES_MODEL_STL || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
            result[[TIME_SERIES_MODEL_STL]] <- stlForecast
        }
    }

    #ETS + ARIMA
    if (timeSeriesModel == TIME_SERIES_MODEL_ETS_ARIMA || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
        result[[TIME_SERIES_MODEL_ETS_ARIMA]] <- modelEtsArima(etsForecast, arimaForecast)
    }

    #ETS + STL
    if (timeSeriesModel == TIME_SERIES_MODEL_ETS_STL || timeSeriesModel == TIME_SERIES_MODEL_ALL) {
        result[[TIME_SERIES_MODEL_ETS_STL]] <- modelEtsStl(etsForecast, stlForecast)
    }

    return(result);
}

entry_script = new.env()

# This method will be called on init in each worker process.
entry_script$init <- function() {
}

# This method will be called on each minibatch.
entry_script$run <- function(minibatch) {

    # Map 1-based optional input ports to variables
    datasetCombined <- minibatch # class: data.frame

    ################### PARAMETERS INIT ###################

    #Convert column names to upper
    for (i in 1:length(names(datasetCombined))) {
        colnames(datasetCombined)[i] <- toupper(colnames(datasetCombined)[i])
    }

    #First row should have parameter values
    datasetParameters <- head(datasetCombined, 1)

    data <- datasetCombined

    print(paste("Generating forecast for granularity attribute: ", data$GRANULARITYATTRIBUTE[1], ", length of dataset is: ", length(data$GRANULARITYATTRIBUTE)))

    #Number of forecast predictions
    horizon <- as.numeric(datasetParameters$HORIZON)

    if (is.na(horizon) || horizon <= 0) {
        stop(paste("Parameter HORIZON must be greater than 0."))
    }

    #Seasonality of historical data
    if (is.null(datasetParameters$SEASONALITY)) {
        seasonality <- 1;
    } else {
        seasonality <- as.numeric(datasetParameters$SEASONALITY);
    }

    if (is.na(seasonality) || seasonality <= 0) {
        stop(paste("Parameter SEASONALITY must be greater than 0."))
    }

    #Start date key from which forecast should be generated
    global_max_datekey <- max(data$DATEKEY)
    if (is.null(datasetParameters$FORECAST_START_DATEKEY)) {
        forecast_start_datekey <- global_max_datekey + 1;
    } else {
        forecast_start_datekey <- as.numeric(datasetParameters$FORECAST_START_DATEKEY);

        if (forecast_start_datekey <= global_max_datekey) {
            stop(paste("Parameter FORECAST_START_DATEKEY must be greater than maximum date key of historical data (", global_max_datekey, ")"))
        }
    }

    #Time series model
    if (is.null(datasetParameters$TIME_SERIES_MODEL)) {
        timeSeriesModel <- TIME_SERIES_MODEL_ALL;
    } else {
        timeSeriesModel <- toupper(datasetParameters$TIME_SERIES_MODEL);
    }

    if (is.na(match(timeSeriesModel, TIME_SERIES_MODELS))) {
        stop(paste("Parameter value of TIME_SERIES_MODEL does not represent any known forecasting model."))
    }

    #Confidence level
    if (is.null(datasetParameters$CONFIDENCE_LEVEL)) {
        confidenceLevel <- 95;
    } else {
        confidenceLevel <- as.numeric(datasetParameters$CONFIDENCE_LEVEL);
    }

    if (is.na(confidenceLevel) || confidenceLevel <= 0 || confidenceLevel >= 100) {
        stop(paste("Parameter CONFIDENCE_LEVEL must be greater than 0 and lower than 100."))
    }

    #Size of a test set in a percent of a total historical data size
    if (is.null(datasetParameters$TEST_SET_SIZE_PERCENT)) {
        testSetSizePercent <- 20;
    } else {
        testSetSizePercent <- as.numeric(datasetParameters$TEST_SET_SIZE_PERCENT);
    }

    if (is.na(testSetSizePercent) || testSetSizePercent < 0 || testSetSizePercent >= 100) {
        stop(paste("Parameter TEST_SET_SIZE_PERCENT must be greater than or equal to 0 and lower than 100."))
    }

    #How gaps in historical data are filled
    if (is.null(datasetParameters$MISSING_VALUE_SUBSTITUTION)) {
        missingValueSubstitution <- 0;
    } else {

        if (is.numeric(datasetParameters$MISSING_VALUE_SUBSTITUTION)) {
            missingValueSubstitution <- as.numeric(datasetParameters$MISSING_VALUE_SUBSTITUTION)
        }
        else {
            missingValueSubstitution <- toupper(datasetParameters$MISSING_VALUE_SUBSTITUTION)

            if (is.na(match(missingValueSubstitution, MISSING_VALUE_OPTIONS))) {
                stop(paste("Parameter value of MISSING_VALUE_SUBSTITUTION does not represent any known substitution option."))
            }
        }
    }

    #How are the historical data gaps filled?
    if (is.null(datasetParameters$MISSING_VALUE_SCOPE)) {
        missingValueScope <- MISSING_VALUE_SCOPE_GRANULARITY_ATTRIBUTE;
    } else {
        missingValueScope <- toupper(datasetParameters$MISSING_VALUE_SCOPE);
    }

    if (is.na(match(missingValueScope, MISSING_VALUE_SCOPE_OPTIONS))) {
        stop(paste("Parameter value of MISSING_VALUE_SCOPE does not represent any known option."))
    }

    #History date range period
    global_min_datekey <- min(data$DATEKEY)
    historyDateRangeFrom <- historyDateRangeTo <- NA
    if (missingValueScope == MISSING_VALUE_SCOPE_HISTORY_DATE_RANGE) {
        if (is.null(datasetParameters$HISTORY_DATE_RANGE_FROM)) {
            historyDateRangeFrom <- global_min_datekey
        } else {
            historyDateRangeFrom <- as.numeric(datasetParameters$HISTORY_DATE_RANGE_FROM)
        }
        if (is.null(datasetParameters$HISTORY_DATE_RANGE_TO)) {
            historyDateRangeTo <- global_max_datekey
        } else {
            historyDateRangeTo <- as.numeric(datasetParameters$HISTORY_DATE_RANGE_TO)
        }

        if (historyDateRangeTo < historyDateRangeFrom) {
            stop(paste("Parameter HISTORY_DATE_RANGE_TO must be greater than parameter HISTORY_DATE_RANGE_FROM"))
        }
    }

    #Seasonality
    if (is.null(datasetParameters$FORCE_SEASONALITY)) {
        forceSeasonality <- FORCE_SEASONALITY_AUTO;
    } else {
        forceSeasonality <- toupper(datasetParameters$FORCE_SEASONALITY);
    }

    if (is.na(match(forceSeasonality, FORCE_SEASONALITY_OPTIONS))) {
        stop(paste("Parameter value of FORCE_SEASONALITY does not represent any known seasonality option."))
    }

    ################### END PARAMETERS INIT ###################

    output <- data.frame(
        GRANULARITYATTRIBUTE = character(0),
        DATEKEY = numeric(0),
        TRANSACTIONQTY = numeric(0),
        SIGMA = numeric(0),
        ERRORPERCENTAGE = numeric(0),
        FORECASTMODELNAME = character(0))

    granularityAttributes <- unique(data$GRANULARITYATTRIBUTE);
    granularityAttributes_num <- length(granularityAttributes)

    min_datekey <- max_datekey <- NA
    #Get minimum and maximum date keys
    if (missingValueScope == MISSING_VALUE_SCOPE_GLOBAL) {
        max_datekey <- max(data$DATEKEY)
        min_datekey <- min(data$DATEKEY)
    } else if (missingValueScope == MISSING_VALUE_SCOPE_HISTORY_DATE_RANGE) {
        max_datekey <- historyDateRangeFrom
        min_datekey <- historyDateRangeTo
    }

    for (i in 1:granularityAttributes_num) {

        granularityAttribute_data <- data[which(data$GRANULARITYATTRIBUTE == granularityAttributes[i]),]

        #Prepare training and test data for given granularity attribute
        granularityAttribute_data <- order_and_fill_missing_values(granularityAttribute_data, missingValueSubstitution, min_datekey, max_datekey)

        full_data <- as.numeric(granularityAttribute_data$TRANSACTIONQTY)

        full_data_ts <- ts(full_data, frequency = seasonality)
        full_data_last_datekey <- granularityAttribute_data$DATEKEY[length(granularityAttribute_data$DATEKEY)];
        full_data_horizon_offset <- forecast_start_datekey - full_data_last_datekey + horizon - 1;

        test_size <- floor(length(granularityAttribute_data$TRANSACTIONQTY) * testSetSizePercent / 100);
        resultTimeSeriesModel <- timeSeriesModel

        if (test_size > 0) {
            #When there is data in the test set then the model will be chosen based on how well it predicts the demand in the test set

            test_data <- tail(as.numeric(granularityAttribute_data$TRANSACTIONQTY), n = test_size);
            train_data <- head(granularityAttribute_data$TRANSACTIONQTY, n = -test_size)

            train_data_ts <- ts(train_data, frequency = seasonality);

            result <- trainModels(timeSeriesModel, train_data_ts, forecastHorizon = test_size, confidenceLevel = confidenceLevel, seasonality, forceSeasonality)

            #Calculate accuracy metrics

            #Mape cannot be calculated when there are zeros in the data
            test_data_na <- replace(test_data, test_data == 0, NaN)

            result_mape <- Inf

            for (name in names(result)) {
                #How big is the error between forecasted demand and actual demand
                current_mape <- mape(test_data_na, result[[name]]$mean)

                if (current_mape < result_mape) {
                    resultTimeSeriesModel <- toupper(name)
                    result_mape <- current_mape
                }
            }

            result <- trainModels(resultTimeSeriesModel, full_data_ts, full_data_horizon_offset, confidenceLevel, seasonality, forceSeasonality)
        }
        else {
            #There is no data in the test set so the model will be chosen based on how well it fits historical data
            result <- trainModels(timeSeriesModel, full_data_ts, full_data_horizon_offset, confidenceLevel, seasonality, forceSeasonality)

            #Mape cannot be calculated when there are zeros in the data
            full_data_na <- replace(full_data, full_data == 0, NaN)

            #MAPE cannot be calculated when the test set is empty
            result_mape <- -1
            min_mape_fitted <- Inf

            for (name in names(result)) {
                #How well the model fits historical data
                current_mape_fitted <- mape(full_data_na, result[[name]]$fitted)

                if (current_mape_fitted < min_mape_fitted) {
                    resultTimeSeriesModel <- toupper(name)
                    min_mape_fitted <- current_mape_fitted
                }
            }
        }

        #Save result to output
        mean_aml <- c()
        sigma_aml <- c()
        mape_aml <- c()

        if (!is.null(result[[resultTimeSeriesModel]])) {
            mean_aml <- result[[resultTimeSeriesModel]]$mean
            sigma_aml <- result[[resultTimeSeriesModel]]$sigma
            mape_aml <- result_mape
        }

        if (length(mean_aml) == 0) {
            paste("Forecast cannot be generated for ", granularityAttributes[i])

            output = addToOutput(
                output,
                granularityAttributes[i],
                -1,
                -1,
                -1,
                -1,
                "")
        }
        else {
            sigma_aml[is.infinite(sigma_aml)] <- MAX_DECIMAL

            #Forecasted values will be sent starting from forecast start date key parameter value
            output = addToOutput(
                output,
                granularityAttributes[i],
                seq(from = forecast_start_datekey, length.out = horizon),
                tail(as.numeric(mean_aml), horizon),
                tail(as.numeric(sigma_aml), horizon),
                mape_aml,
                resultTimeSeriesModel)
        }
    }

    # Each parallel run step minibatch processing returns an array of string.
    # Lines from all the minibatches are combined into 1 output file.
    result <- paste(
        paste('"', output$GRANULARITYATTRIBUTE, '"', sep = ""),
        output$DATEKEY,
        output$TRANSACTIONQTY,
        output$SIGMA,
        output$ERRORPERCENTAGE,
        output$FORECASTMODELNAME,
        sep = ",")
}


#' @export
extend.color.range <- function(colors, n, weight=rep(1, length(colors)-1)) {
  if ( n < length(colors) ) return ( colors )
  if ( length(weight) != length(colors)-1 ) stop('Must be one fewer weights than colors.')

  red.part <- strtoi(paste('0X', substring(colors, 2, 3), sep=''))/2^8
  grn.part <- strtoi(paste('0X', substring(colors, 4, 5), sep=''))/2^8
  blu.part <- strtoi(paste('0X', substring(colors, 6, 7), sep=''))/2^8

  new.red <- approx(c(0, cumsum(weight)/sum(weight)), red.part, n=n)$y
  new.grn <- approx(c(0, cumsum(weight)/sum(weight)), grn.part, n=n)$y
  new.blu <- approx(c(0, cumsum(weight)/sum(weight)), blu.part, n=n)$y

  return ( rgb(new.red, new.grn, new.blu) )
}

# # Example!
# library('RColorBrewer')
# wee.colors <- brewer.pal(9, 'Spectral')
# wee.colors <- c(rgb(0, 0:3/3, 0), rgb(1:3/3, 1, 1:3/3))
# wee.more.colors <- extend.color.range(wee.colors, 100)
# wee.nonlinear.colors <- extend.color.range(wee.colors, 100, c(1:8))
#
# par(mfcol=c(1, 3))
# image(matrix(1:100, 1), col=wee.colors)
# image(matrix(1:100, 1), col=wee.more.colors)
# image(matrix(1:100, 1), col=wee.nonlinear.colors)

#' @export
lighten.colors <- function(colors, pct) {
  if ( length(pct) == 1 ) pct <- rep(pct, length(colors))

  red.part <- strtoi(paste('0X', substring(colors, 2, 3), sep=''))/2^8
  grn.part <- strtoi(paste('0X', substring(colors, 4, 5), sep=''))/2^8
  blu.part <- strtoi(paste('0X', substring(colors, 6, 7), sep=''))/2^8

  new.red <- pct+(1-pct)*red.part
  new.grn <- pct+(1-pct)*grn.part
  new.blu <- pct+(1-pct)*blu.part

  return ( rgb(new.red, new.grn, new.blu) )
}

#' @export
darken.colors <- function(colors, pct) {
  if ( length(pct) == 1 ) pct <- rep(pct, length(colors))

  red.part <- strtoi(paste('0X', substring(colors, 2, 3), sep=''))/2^8
  grn.part <- strtoi(paste('0X', substring(colors, 4, 5), sep=''))/2^8
  blu.part <- strtoi(paste('0X', substring(colors, 6, 7), sep=''))/2^8

  new.red <- (1-pct)*red.part
  new.grn <- (1-pct)*grn.part
  new.blu <- (1-pct)*blu.part

  return ( rgb(new.red, new.grn, new.blu) )
}

#' Display colors in a palette
#' @export
display.pal <- function(colors) {
  image(matrix(1:length(colors), ncol=1), col=colors, ann=FALSE, xaxt='n', yaxt='n', bty='n')
}


# ......................................................................................
# ................. Cvičení 13. Neparametrické testy, testy dobré shody.................
# .................. Michal Béreš, Martina Litschmannová, Adéla Vrtková.................
# ......................................................................................

# Nezobrazuje-li se vám text korektně, nastavte File \ Reopen with Encoding... na UTF-8
# Pro zobrazení obsahu skriptu použijte CTRL+SHIFT+O
# Pro spouštění příkazů v jednotlivých řádcích použijte CTRL+ENTER

#  Testování shody rozdělení pravděpodobnosti diskrétní NV (o konečném počtu hodnot)  ####-
# test dobré shody
# - testujeme zda naměřená data (jejich relativní četnosti) souhlasí s nějakým
# konkrétním rozdělením (tedy jeho pravděpodobnostmi)
# - testujeme pomocí $\chi^2$ testu dobré shody
# - předpoklady testu: (POZOR týkají se předpokládaných četností - tedy těch které
# bychom sledovali pokud by naměřená data byla 100% dle rozdělení v hypotéze)
#     - Očekávané četnosti ≥ 2,
#     - alespoň 80% očekávaných četností > 5
# - testová statistika (ta která má $\chi^2$ rozdělení) je $G = \sum_{i = 1}^k (O_i -
# E_i)^2 / E_i$
# - rozdělení ma stupeň volnosti $df = k - 1 - h$
#     - k je počet možností
#     - h je počet odhadovaných parametrů (toto se týká neúplně specifikovaných testů)

# ukázka viz příklad 1

# * Test dobré shody pro spojitou náhodnou veličinu (případně diskrétní o nekonežném ####
# počtu hodnot)
# - musíme převést na tabulku s konečným počtem hodnot
# - u diskrétní (např. poison) shlukneme od určitého  počtu kolonek např. 4,5,6,... na
# "4 a více"
# - u spojité vyrobíme sérii intervalů a koukáme se kolik hodnot spadne do daného
# intervalu
#     - např.: (-$\infty$, 3), <3, 4), ..., <10, $\infty$)
#     - pak musíme pro očekávané rozdělení napočítat pro každý interval kolik % dat do
# nich patří, čímž získáme tabulku očekávaných pravděpodobností
# - dále pokračujeme jako u předchozího
# - pro testování normality rozdělení existuje funkce pearson.test(data) z balíčku
# nortest

# ukázka příklady 2,3,4

#  Kontingenční tabulky ####
# - tabulky obsahující data v závislosti na dvou faktorech
# - jeden z faktorů je z pravidla nezávislá proměnná u které sledujeme, zda má vliv na
# druhý faktor (závislá proměnná)
#     - nezávislá proměnná je zpravidla v řádcích
#     - závislá je zpravidla ve sloupcích
# - pozor celé testování zkoumá korelaci, nikoliv kauzalitu! Kauzalita se dá posoudit
# "expertním" zhodnocením
#     - statistický závěr: existuje statisticky významná závislost mezi nezávislou a
# závislou proměnnou (korelace)
#     - expertní posouzení: nezávislá proměnná statisticky významně ovlivňuje závislou
# proměnnou (kauzalita)

# * Vizualizace kontingenční tabulky ####
# - vizualizace např. pomocí funkce barplot
#     - pozor na to co jsou řádky a sloupce, vždy chceme aby jednotlivé dělené sloupce
# byly přes nezávislé proměnné (každý sloupec pro jednu hodnotu nezávislé proměnné)
#     - beside = T určuje zda chceme přilehlé sloupce sloučit do jednoho děleného
# sloupce, či ne
# - preferovaná vizualizace pomocí mozaikového grafu mosaicplot
#     - totéž co u barplotu, spojené sloupce musí být přes nezávislé proměnné

# ukázky v příkladech 5,6,7

# * Míry závislosti v koningenční tabulce ####
# - Koeficient korelace CC
# - Korigovaný koeficient korelace CCcor
# - Cramerův koeficient V
#     - tento budeme používat především
#     - funkce cramersV(kont.tab) z balíčku lsr

# ukázky v příkladech 5,6,7

# * Test závislosti v kontingenční tabulce ####
# - $H_0:$ neexistuje závislost mezi nezávislou (např. je kouřák) a závislou (např. trpí
# onemocněním) proměnnou
# - $H_A: \neg H_0$
# - funkce chisq.test(kont.tab)
#     - předpoklady: Očekávané četnosti ≥ 2, alespoň 80% očekávaných četností > 5
#     - očekávané četnosti se dají zjistit z chisq.test(kont.tab)\$expected

#  Asociační tabulky ####
# - jedná se o speciální případ kontingenční tabulky
# - má vždy právě 2 možnosti pro závislou a právě 2 možnosti pro nezávislou proměnnou

# * Povinný tvar asociační tabulky ####
# - řádky označují možnosti nezávislé proměnné
#     - první řádek je takzvaná exponovaná část populace (ta vystavena jevu který
# zkoumáme - např. kuřáci poku zkoumáme vliv kouření)
#     - druhý řádek je neexponovaná část populace
# - sloupce označují možnosti závislé proměnné
#     - první sloupec označuje výskyt zkoumaného jevu (např. výskyt nemoci, chyba
# výrobku, ...)
#     - druhý sloupec označuje zbytek - bez výskytu zkoumaného jevu

# * Relativní riziko a poměr šancí ####
# - Relativní riziko a poměr šancí podávají stejnou informaci, pouze v jiném formátu
# - všechny bodové IO se spočtou pomocí funkce epi.2by2(asoc.tab) z balíčku epiR
#     - funkce bere jako vstup asociační tabulku, která musí být ve správném formátu!

# ** Relativní riziko ####
# - značíme $RR$
# - jedná se o poměr rizika (pravděpodobnost výskytu zkoumaného jevu) u exponované a
# neexponované populace
#     - pokud je roven 1 tak to značí stejné pravděpodobnosti výskytu u exponované i u
# neexponované
#     - pokud je větší než 1 pak exponovaná polulace má větší pravděpodobnost výskytu
#     - pokud je menší než 1 pak exponovaná populace má menší pravděpodobnost výskytu
# - bodový odhad $\hat{RR}$ se spočte jako poměr rel. četností zkoumaného jevu u
# exponované a neexponované populace
# - funkce epi.2by2 dodá intervalové odhady
# - pokud IO neobsahuje hodnotu 1 pak existuje statisticky významná závislost mezi
# závislou a nezávislou proměnnou

# ** Poměr šancí ####
# - značíme $OR$
# - jedná se o poměr šancí (šance výskytu zkoumaného jevu) u exponované a neexponované
# populace
#     - pokud je roven 1 tak to značí stejné šance výskytu u exponované i u neexponované
#     - pokud je větší než 1 pak exponovaná polulace má větší šanci výskytu
#     - pokud je menší než 1 pak exponovaná populace má menší šanci výskytu
# - bodový odhad $\hat{OR}$ se spočte jako poměr šancí (výběrových) zkoumaného jevu u
# exponované a neexponované populace
# - funkce epi.2by2 dodá intervalové odhady
# - pokud IO neobsahuje hodnotu 1 pak existuje statisticky významná závislost mezi
# závislou a nezávislou proměnnou

# ukázka v příkladu 7

#  Příklady (testy dobré shody) ####
# * Příklad 1. ####
# Hodilo se 6 000 krát hrací kostkou a zaznamenaly se počty padlých ok.
# Je možné na základě příslušného testu na hladině významnosti 0,05 spolehlivě tvrdit,
# že kostka
# je „falešná“, tj. že pravděpodobnosti všech čísel na kostce nejsou stejné?
# Obrázek viz sbírka úloh.

#H0: Kostka je férová. (tedy všechny pravděpodobnosti jsou 1/6)
#Ha: Kostka není férová. (negace H0)

x = c(1,2,3,4,5,6)
n.obs = c(979,1002,1015,980,1040,984)
p.exp = c(1/6,1/6,1/6,1/6,1/6,1/6)
n.exp = 6000*p.exp
n.exp # nutno zkontrolovat předpoklady testu
# Všechny očekávané četnosti jsou větší než 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1 - pchisq(x.obs,5)
p.hodnota

# Na hladině významnosti 0,05 nezamítáme HO (p-hodnota = 0,711,
# Chí-kvadrát test nezávislosti, df = 5).

# * Příklad 2. ####
# Výrobní firma odhaduje počet poruch určitého zařízení během 100 hodin pomocí
# Poissonova
# rozdělení s parametrem 1,2. Zaměstnanci zaznamenali pro kontrolu skutečné počty poruch
# celkem ve 150 100hodinových intervalech (výsledky jsou uvedeny v tabulce). Ověřte
# čistým testem významnosti, zda má počet poruch daného zařízení během 100 hodin
# skutečně Poissonovo
# rozdělení s parametrem λt = 1,2.
# Obrázek viz sbírka úloh.

# Úplně specifikovaný test

# H0: Počet poruch během 100 hodin provozu lze modelovat
#     Poissonovým rozdělením s parametrem 1,2.
# Ha: Počet poruch během 100 hodin provozu nelze modelovat
#     Poissonovým rozdělením s parametrem 1,2.

x = c(0,1,2,3,4)
n.obs = c(52,48,36,10,4)

p.exp = dpois(x,1.2)
p.exp[5] = 1 - sum(p.exp[1:4])
p.exp
sum(p.exp)

n.exp = 150*p.exp
n.exp # nutno zkontrolovat předpoklady testu
# 4 z 5 očekávaných četnosti, tj. 80%, jsou větší než 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1-pchisq(x.obs,4)
p.hodnota

# Na hladině významnosti 0,05 nezamítáme HO (p-hodnota = 0,590,
# Chí-kvadrát test nezávislosti, df = 4).

# * Příklad 3. ####
# Zaměstnanci zaznamenali pro kontrolu počty poruch celkem ve 150 100hodinových
# intervalech
# (výsledky jsou uvedeny v tabulce). Ověřte čistým testem významnosti, zda má počet
# poruch
# daného zařízení během 100 hodin skutečně Poissonovo rozdělení.
# Obrázek viz sbírka úloh.

# Neúplně specifikovaný test

# H0: Počet poruch během 100 hodin provozu lze modelovat
#     Poissonovým rozdělením.
# Ha: Počet poruch během 100 hodin provozu nelze modelovat
#     Poissonovým rozdělením.

x = c(0,1,2,3,4)
n.obs = c(52,48,36,10,4)

lambda.t = weighted.mean(x,n.obs)   # odhad parametru Poissonova rozdělení
lambda.t

p.exp = dpois(x,lambda.t)
p.exp[5] = 1 - sum(p.exp[1:4])
p.exp
sum(p.exp)

n.exp = 150*p.exp
n.exp # nutno zkontrolovat předpoklady testu
# 4 z 5 očekávaných četnosti, tj. 80%, jsou větší než 5.

x.obs = sum(((n.obs-n.exp)^2)/n.exp)
x.obs

p.hodnota = 1-pchisq(x.obs,3)
p.hodnota

# Na hladině významnosti 0,05 nezamítáme HO (p-hodnota = 0,491,
# Chí-kvadrát test nezávislosti, df = 3).

# * Příklad 4.  ####
# Na dálnici byly v průběhu několika minut měřeny časové odstupy (s) mezi průjezdy
# jednotlivých vozidel. Zjištěné hodnoty těchto odstupů jsou zaznamenány v souboru
# dalnice.xlsx. Ověřte, zda se jedná o data z normálního rozdělení (použijte test dobré
# shody).

# automatický test dobré shody ze spojitých dat

dalnice = readxl::read_excel("data/neparametricke_hypotezy.xlsx", sheet=2)
colnames(dalnice)="hodnoty"
head(dalnice)

mu = mean(dalnice$hodnoty)
sigma = sd(dalnice$hodnoty)
mu
sigma

# generování hodnot pro osu x
xfit=seq(from = -20, to = 30, length = 100)
# generování hodnot pro osu y
yfit=dnorm(xfit, mean = mu, sd = sigma)

hist(dalnice$hodnoty, freq = FALSE, xlim = c(-20, 30))
# do posledního grafu přidání křivky na základě výše vygenerovaných hodnot
lines(xfit, yfit, col="black", lwd=2)

# install.packages("nortest")

#H0: Rozestupy mezi vozidly lze modelovat normálním rozdělením.
#Ha: Rozestupy mezi vozidly nelze modelovat normálním rozdělením.

nortest::pearson.test(dalnice$hodnoty)

# Určení počtu stupňů volbnosti
pom = nortest::pearson.test(dalnice$hodnoty, n.classes = 5)
attributes(pom)

pom$method
pom$n.classes
pom$df
pom$p.value

# Na hladině významnosti 0,05 lze zamítnout HO (p-hodnota << 0,001,
# Chí-kvadrát test dobré shody, df = 12).

# test co už znáte
shapiro.test(dalnice$hodnoty)

#  Příklady na kontingenční a asociační tabulky ####
# * Příklad 5. ####
# Rozhodněte na základě datového souboru experimentovani-s-telem.xls (Dudová, J. -
# Experimentování s tělem (výsledky průzkumu), 2013. Dostupné online na
# http://experimentovani-stelem.vyplnto.cz), zda existuje souvislost mezi pohlavím
# respondentů a tím, zda mají tetování. Pro posouzení míry kontingence použijte
# Cramerovo V.

tet = readxl::read_excel("./CV13/data/neparametricke_hypotezy.xlsx", sheet=3)
head(tet)

tet = tet[,c(6,10)]
colnames(tet) = c("pohlavi","tetovani")
head(tet)

# Preprocessing
# Varianty kat. proměnných (faktorů) je nutné uspořádat a pojmenovat tak,
# jak mají být uspořádány a pojmenovány v kont. tabulce

kont.tab = table(tet$pohlavi, tet$tetovani)
kont.tab

colnames(kont.tab) = c("má tetování","nemá tetování")
kont.tab

# Explorační analýza
prop.table(kont.tab)    # sdružené relativní četnosti
prop.table(kont.tab,1)  # řádkové relativní četnosti
prop.table(kont.tab,2)  # sloupcové relativní četnosti

# Vizualizace ve standardním R
# Shlukový sloupcový graf
# srovnejte grafy, který z grafů je pro prezentaci daných dat vhodnější

options(repr.plot.width = 12) # šířka grafů v Jupyteru
par(mfrow = c(1, 2))          # matice grafů 1x2

barplot(t(kont.tab),
        legend = colnames(kont.tab),
        beside = T)

barplot(kont.tab,
        legend = rownames(kont.tab),
        beside = T)

# Skládaný sloupcový graf

options(repr.plot.width = 12) # šířka grafů v Jupyteru
par(mfrow = c(1, 2))          # matice grafů 1x2

barplot(t(kont.tab),
        legend = colnames(kont.tab))

barplot(kont.tab,
        legend = rownames(kont.tab))

# Mozaikový graf

options(repr.plot.width = 8) # šířka grafů v Jupyteru

mosaicplot(t(kont.tab),
           las = 1, # otočení popisků osy y
           color = gray.colors(2))

# srovnejte, který z grafů je pro prezentaci daných dat vhodnější
mosaicplot(kont.tab,
           las = 1,
           color = gray.colors(2))

# install.packages("lsr")

# Výpočet Cramerova V ####
lsr::cramersV(kont.tab)

# Test nezávislosti v kontingenční tabulce

# H0: Data jsou nezávislá -> to jestli je jedinec muž nebo žena
# neovlivní jeho pravděpodobnost, že budemít tetování
# HA: negace H0 (existuje závislost)

pom = chisq.test(kont.tab)
attributes(pom)

pom$expected # Nutné pro ověření předpokladů
# Všechny očekávané četnosti jsou větší než 5.

pom

# Na hladině významnosti 0,05 lze zamítnout HO (p-hodnota = 0,003,
# Chí-kvadrát test dobré shody, df = 1).
# Pozorovanou závislost lze hodnotit jako slabou (Cramerovo V = 0,121).

# * Příklad 6. ####
# Pro diferencovaný přístup v personální politice potřebuje vedení podniku vědět, zda
# spokojenost v práci závisí na tom, jedná-li se o pražský závod či závody mimopražské.
# Výsledky šetření jsou v následující tabulce. Zobrazte data pomocí mozaikového grafu a
# na základě testu nezávislosti v kombinační tabulce rozhodněte o závislosti
# spokojenosti v zaměstnání na umístnění podniku. Pro posouzení míry kontingence
# použijte Cramerovo V.
# Obrázek viz sbírka úloh.

# Nemáme k dispozici datovou matici, tj. kont. tabulku musíme zadat "ručně"
kont.tab = matrix(c(10,25,50,15,20,10,130,40),
                  nrow=2,byrow=T)
rownames(kont.tab) = c("Praha","Venkov")
colnames(kont.tab) = c("velmi nespokojen","spíše nespokojen",
                       "spíše spokojen","velmi spokojen")
kont.tab = as.table(kont.tab)
kont.tab

# Explorační analýza ####
prop.table(kont.tab)  # sdružené relativní četnosti
prop.table(kont.tab,1)  # řádkové relativní četnosti
prop.table(kont.tab,2)  # sloupcové relativní četnosti

# Vizualizace ve standardním R
# Mozaikový graf
mosaicplot(kont.tab,
           las = 1, # otočení popisků osy y o 90
           color = gray.colors(4))

# Cramerovo V
lsr::cramersV(kont.tab)

# H0: Mezi spokojenosti v práci a umístěním podniku neexistuje souvislost.
# Ha: Mezi spokojenosti v práci a umístěním podniku existuje souvislost.

# Chí-kvadrát test nezávislosti v kontingenční tabulce ####
pom = chisq.test(kont.tab)
pom$expected
# Všechny očekávané četnosti jsou větší než 5.

pom

# Na hladině významnosti 0,05 lze zamítnout HO (p-hodnota << 0,001,
# Chí-kvadrát test dobré shody, df = 3).
# Pozorovanou závislost lze hodnotit jako středně silnou (Cramerovo V = 0,296)

# * Příklad 7. (Asociační tabulka) ####
# V letech 1965 až 1968 bylo v kohortové studii kardiovaskulárních onemocnění v rámci
# „Honolulu Heart Program“ zahájeno sledování 8 006 mužů, z nichž 7 872 nemělo při
# zahájení studie v anamnéze mrtvici (apoplexii). Z tohoto počtu bylo 3 435 kuřáků a 4
# 437 nekuřáků. Při jejich sledování po dobu 12 let dostalo mrtvici 171 mužů ve skupině
# kuřáků a 117 mužů ve skupině nekuřáků.
# *** a)  ####
# Zapište zjištěné výsledky do asociační tabulky.

kont.tab = matrix(c(171,3264,117,4320),nrow=2,byrow=T)
rownames(kont.tab) = c("kuřák","nekuřák")
colnames(kont.tab) = c("ano","ne")
kont.tab

# doplnění tabulky absolutních četností
kont.tab.full = matrix(rep(0,9), nrow=3, ncol=3)
rownames(kont.tab.full) = c("kuřák", "nekuřák", "sum")
colnames(kont.tab.full) = c("ano", "ne", "sum")

kont.tab.full[1:2, 1:2] = kont.tab
kont.tab.full[1:2, 3] = rowSums(kont.tab)
kont.tab.full[3, 1:2] = colSums(kont.tab)
kont.tab.full[3, 3] = sum(kont.tab)
kont.tab.full

# doplnění tabulky relativních četností
kont.tab.rel = matrix(rep(0,9), nrow=3, ncol=3)
rownames(kont.tab.rel) = c("kuřák", "nekuřák", "sum")
colnames(kont.tab.rel) = c("ano", "ne", "sum")

kont.tab.rel[1:2, 1:2] = prop.table(kont.tab)
kont.tab.rel[1:2, 3] = rowSums(kont.tab.rel[1:2, 1:2])
kont.tab.rel[3, 1:2] = colSums(kont.tab.rel[1:2, 1:2])
kont.tab.rel[3, 3] = sum(kont.tab.rel[1:2, 1:2])
kont.tab.rel

# *** b) ####
# Na základě vizuálního posouzení odhadněte vliv kouření na výskyt kardiovaskulárních
# onemocnění.

# Vizualizace mozaikovým grafem v základním R
mosaicplot(kont.tab,
           color = gray.colors(2))

# Výpočet Cramerova V ####
lsr::cramersV(kont.tab)

# Dle mozaikového grafu a Cramerova V (0,061) lze souvislost mezi kuřáctvím
# a výskytem apoplexie hodnotit jako velmi slabou.

# *** c) ####
# Určete absolutní riziko vzniku kardiovaskulárních onemocnění u kuřáků a nekuřáků.

# riziko = pravděpodobnost
kont.tab.full

# Kuřáci
# Kontrola předpokladů
p = 171/3435
p

9/(p*(1-p))
# OK (3 435 > 190,3)

# Výpočet bodového a 95% Clopperova-Pearsonova intervalového odhadu
prop.test(x = 171, n = 3435)

# U kuřáku je riziko vzniku apoplexie cca 5,0 %. 95% Clopperův-Pearsonův
# intervalový odhad tohoto rizika je 4,2 % až 5,8 %.

# Nekuřáci
# Kontrola předpokladů
p = 117/4437
p

9/p/(1-p)
# OK (4 437 > 350,6)

# Výpočet bodového a 95% Clopperova-Pearsonova intervalového odhadu
prop.test(117,4437)

# U nekuřáku je riziko vzniku apoplexie cca 2,6 %. 95% Clopperův-Pearsonův
# intervalový odhad tohoto rizika je 2,1 % až 3,2 %.

# *** d) ####
# Určete relativní riziko (včetně 95% intervalového odhadu) vzniku kardiovaskulárních
# onemocnění u kuřáků a nekuřáků. Vysvětlete praktický význam zjištěných výsledků.

# install.packages("epiR")

kont.tab

epiR::epi.2by2(kont.tab)

# U kuřáků je cca 1,89 krát vyšší riziko apoplexie než u nekuřáků. 95%
# intervalový odhad tohoto relativního rizika je 1,50 až 2,38.
# Dle intervalového odhadu relativního rizika je zřejmé, že na hladině
# významnosti 0,05 je u kuřáků statisticky významně vyšší riziko vzniku
# apoplexie než u nekuřáků.

# *** e) ####
# Určete absolutní šance vzniku kardiovaskulárních onemocnění u kuřáků a nekuřáků.

# U kuřáku je šance vzniku apoplexie cca 52:1 000. Tj. u 1 052 kuřáků
# lze očekávat cca 52 výskytů apoplexie.
# U nekuřáku je šance vzniku apoplexie cca 27:1 000. Tj. u 1 027 nekuřáků
# lze očekávat cca 27 výskytů apoplexie.

#  *** f) ####
#  Určete relativní šance vzniku kardiovaskulárních onemocnění u kuřáků.

# U kuřáků je cca 1,93 (= 0,0524/0,0271) krát vyšší šance apoplexie
# než u nekuřáků. 95% intervalový odhad tohoto poměru
# šancí je 1,52 až 2,46.
# Dle intervalového odhadu poměru šancí je zřejmé, že na hladině
# významnosti 0,05 je u kuřáků
# statisticky významně vyšší šance na vznik apoplexie než u nekuřáků.

# *** g) ####
# Rozhodněte na hladině významnosti 0,05 o závislosti výskytu kardiovaskulárních chorob
# na kouření.

# Pozor! Příkaz epi.2by2 nemá jako výstup očekávané četnosti pro
# Chí-kvadrát test nezávislosti.
# Není tak možno ověřit předpoklady testu!

# H0: Mezi kouřením a výskytem apoplexie neexistuje souvislost.
# Ha: Mezi kouřením a výskytem apoplexie existuje souvislost.

pom = chisq.test(kont.tab)
pom$expected
# Všechny očekávané četnosti jsou větší než 5.

pom

lsr::cramersV(kont.tab)

#Na hladině významnosti 0,05 lze zamítnout HO (p-hodnota << 0,001,
# Chí-kvadrát test dobré shody,
# df = 1). Pozorovanou závislost lze hodnotit jako velmi slabou
# (Cramerovo V = 0,061).


# Effect of temperature on air pressure.

logger.names <- grep('barometer/', gwloggeR.data::enumerate(), value = TRUE)

logger.names <- setdiff(logger.names, 'barometer/BAOL016X_W1666.csv')
logger.names <- setdiff(logger.names, 'barometer/BAOL050X_56819.csv') # high freq manu in range of 80 cmH2O

df <- lapply(logger.names, function(name) gwloggeR.data::read(name)$df)
df <- data.table::rbindlist(df, use.names = TRUE, fill = TRUE)
df <- df[!is.na(TEMPERATURE_VALUE), ]
df <- df[!is.na(PRESSURE_VALUE), ]

with(df, hist(TEMPERATURE_VALUE, breaks = 1000, main = '',
              xlim = quantile(TEMPERATURE_VALUE, probs = c(0.0001, 0.9999))))
with(df, hist(PRESSURE_VALUE, breaks = 1000, main = '',
              xlim = quantile(PRESSURE_VALUE, probs = c(0.0001, 0.9999))))

range(df$TEMPERATURE_VALUE)
range(df$PRESSURE_VALUE)

df.quant <- df[
  , .(Q.025 = quantile(PRESSURE_VALUE, 0.025),
      Q.5 = quantile(PRESSURE_VALUE, 0.5),
      Q.975 = quantile(PRESSURE_VALUE, 0.975),
      N = .N),
  by = .(TEMPERATURE_VALUE = round(TEMPERATURE_VALUE))][N > 200, ]

summary((fit.lm <- lm(data = df, formula = PRESSURE_VALUE ~ TEMPERATURE_VALUE)))
summary((fit.rq <- quantreg::rq(data = df, formula = PRESSURE_VALUE ~ TEMPERATURE_VALUE)))
# fit <- bayesQR::bayesQR(data = df, formula = PRESSURE_VALUE ~ TEMPERATURE_VALUE, ndraw = 10)

ggplot2::ggplot(data = df, mapping = ggplot2::aes(x = TEMPERATURE_VALUE, y = PRESSURE_VALUE)) +
  ggplot2::geom_point(pch = '.') +
  ggplot2::geom_line(data = df.quant, mapping = ggplot2::aes(x = TEMPERATURE_VALUE, y = Q.025), col = 'red', size = 1.2, alpha = 0.4) +
  ggplot2::geom_line(data = df.quant, mapping = ggplot2::aes(x = TEMPERATURE_VALUE, y = Q.5), col = 'red', size = 1.2, alpha = 0.9) +
  ggplot2::geom_line(data = df.quant, mapping = ggplot2::aes(x = TEMPERATURE_VALUE, y = Q.975), col = 'red', size = 1.2, alpha = 0.4) +
  ggplot2::coord_cartesian(ylim = quantile(df$PRESSURE_VALUE, probs = c(0.0001, 0.9999)),
                           xlim = quantile(df$TEMPERATURE_VALUE, probs = c(0.0001, 0.9999))) +
  ggplot2::theme_light()

ggplot2::ggsave('./drifts/analysis_05/air_pressure_temp_simple.png', width = 1280/96, height = 720/96, dpi = 96)

ggplot2::ggplot(data = df, mapping = ggplot2::aes(x = TEMPERATURE_VALUE, y = PRESSURE_VALUE)) +
  ggplot2::geom_point(pch = '.') +
  ggplot2::geom_line(data = df.quant, mapping = ggplot2::aes(x = TEMPERATURE_VALUE, y = Q.025), col = 'red', size = 1.2, alpha = 0.4) +
  ggplot2::geom_line(data = df.quant, mapping = ggplot2::aes(x = TEMPERATURE_VALUE, y = Q.5), col = 'red', size = 1.2, alpha = 0.9) +
  ggplot2::geom_line(data = df.quant, mapping = ggplot2::aes(x = TEMPERATURE_VALUE, y = Q.975), col = 'red', size = 1.2, alpha = 0.4) +
  ggplot2::geom_smooth(method = 'lm', formula = y ~ x, col = 'yellow', size = 1.2, alpha = 0.9) +
  ggplot2::geom_quantile(quantiles = 0.5, formula = y ~ x, col = 'blue', size = 1.2, alpha = 0.9) +
  ggplot2::coord_cartesian(ylim = quantile(df$PRESSURE_VALUE, probs = c(0.0001, 0.9999)),
                           xlim = quantile(df$TEMPERATURE_VALUE, probs = c(0.0001, 0.9999))) +
  ggplot2::theme_light()

ggplot2::ggsave('./drifts/analysis_05/air_pressure_temp_regressed.png', width = 1280/96, height = 720/96, dpi = 96)


throws<-34
expectedSixs<-3
simulations<-100000000
got<-0
for(i in 1:simulations){
  v<-runif(throws,0,6)
  if(length(v[v>5])>=3){
    got<-got+1
  }
  if(i%%100000==0){
    cat(sprintf("\rSimulointeja % 8d: todennäköisyys %.4f %%",
              i,got/i*100))
  }
}


#' @title simulateMixtures
#' @description Simulate Mixtures
#' @param \code{k} is the number of clusters
#' @param \code{means} is the median for each cluster
#' @param \code{sigma} is the standard deviation for each cluster
#' @param \code{prop} is the proportion of the total sample reprensent by each density normalized to one
#' @param \code{size} is the length of the output vector
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
simulateMixtures <- function(k,means,sigmas,prop=NA,size=10000) {
	if(length(means)!=length(sigmas) | length(means) !=k | length(sigmas)!=k) stop('Vector lengths for means,sigmas and props need to match the number of clusters (k)')
			if(any(is.na(prop))) prop <- rep(1/k,length.out=k)
			prop 	<- 	prop/(sum(prop))
			n 		<- 	prop * size

			v <- c()

			for(i in 1:k) {
				 	w <- rnorm(n[i],means[i],sigmas[i])
					v <- c(v,w)
			}

			return(v)
	}


# With realistic parameters, how many posts do I need for user to
# propery re-esmite their cluster given that I know the real parameters for each cluster?
source('thread_generator.r')

# In Gomez 2013, they generate 100 different sets of parameters and estimate then in N=50, 500, 5000, 50000 threads
# we can also do this for nusers = 2, 10, 100, 1000?

set.seed(1)
alphas <- c(0.1, 0.5)
betas <- c(0.1, 0.5)
taus <- c(0.1, 0.5)
z <- c(1,2)

# Create dataset
##############################################
# Create trees in parallel
cl <- makeCluster(detectCores()-1)
clusterEvalQ(cl, {library(igraph); source('thread_generator.r')})
clusterExport(cl, c("alphas", "betas", "taus", "z"))
trees <- parLapply(cl, 1:10000, function(i) gen.thread.Lumbreras2016(n=100, z=z, alphas=alphas, betas=betas, taus=taus) )
stopCluster(cl)

################ SEQUENTIAL
#set.seed(1)
#alphas <- c(0.1,0.5)
#betas <- c(0.1,0.5)
#taus <- c(0.1, 0.5)
#z <- c(1,2)
#trees <- replicate(1000,  gen.thread.Lumbreras2016(n=100, z=z, alphas=alphas, betas=betas, taus=taus), simplify = FALSE)

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

# Cast to dataframes in parallel
ncores <- detectCores() - 2
cl<-makeCluster(ncores, outfile="", port=11439)
clusterEvalQ(cl, {library(igraph); library(dplyr)})
data.parlapply <- parLapply(cl, trees, tree.to.data)
stopCluster(cl)

# Join dataframes adding thread id
for (i in 1:length(data.parlapply)){
  data.parlapply[[i]]$thread <- i
}
data.parlapply <- rbindlist(data.parlapply)
df.trees <- data.frame(thread = data.parlapply$thread,
                       user = data.parlapply$user,
                       post = data.parlapply$post,
                       t = data.parlapply$t,
                       parent = data.parlapply$parent,
                       popularity = data.parlapply$popularity,
                       lag = data.parlapply$lag)

## Select a subset of N threads
N <- 50
id.trees <- sample(1:10000, N)
df.trees.subset <- filter(df.trees, thread %in% id.trees)

### Compute p(Z | X, alpha, beta, tau)
K <- length(alphas)
users <- unique(df.trees.subset$user)
U <- length(users)
responsabilities <- matrix(nrow = U, ncol = K)
pis <- rep(1/ncol(responsabilities), ncol(responsabilities))

for (u in 1:U){
  responsabilities[u,] <- update_responsabilities(df.trees.subset, u, pis, alphas, betas, taus)
}

print(responsabilities)


#' Convert Daily Prices to Monthly Returns
#'
#' @param prices Vector of monthly prices
#'
#' @return Vector of monthly returns. First element will be NA.
#' @export
#'
#' @examples convert_prices_to_monthly_returns(rnorm(30, 100, 1))
convert_prices_to_monthly_returns <- function(prices){
  c(NA, prices[2:length(prices)] / prices[(2:length(prices)) - 1] - 1)
}

#' Get Monthly Returns
#'
#' Only returns full months.  Dates are last business days of the month.
#'
#' @param symbols Character vector of symbols
#' @param tiingo_token The token for tiigo API
#' @param start_date Start date
#' @param end_date End date.
#'
#' @return Vector of monthly returns.
#' @export
#'
#' @examples get_monthly_returns(symbols="IVV",
#' start_date = as.Date("2014-12-31"),
#' end_date = as.Date("2018-12-31"))
get_monthly_returns <- function(symbols, tiingo_token=Sys.getenv("TIINGO_TOKEN"),
                                start_date=NULL, end_date=NULL){
  riingo::riingo_set_token(tiingo_token)
  prices <- riingo::riingo_prices(symbols, resample_frequency = "monthly",
                                  start_date = start_date,
                                  end_date = end_date)
  prices$date <- as.Date(prices$date)
  out <- tibble(ticker=character(0), date=numeric(0), Ra=numeric(0))
  for(sym in symbols){
    prices.filtered <- prices[prices$ticker == sym, c("ticker", "date", "adjClose")]
    if(nrow(prices.filtered) > 1){
      Ra <- convert_prices_to_monthly_returns(prices.filtered[, "adjClose", drop=TRUE])
      out <- rbind(out, cbind(prices.filtered[, c("ticker", "date")], Ra))
    }
  }
  out <- out[stats::complete.cases(out), ]
  colnames(out) <- c("symbol", "date", "Ra")
  out$date <- ceiling_date(out$date, unit="months") %m-% days(1)
  return(out)
}


# read in soc-ec table
se <- read.csv("../modelInput/SocEc.csv", stringsAsFactors=FALSE)

# select what you want
se <- data.frame(
    fips = se$FIPS,
    state = se$State,
    area_name = se$Area_Name,
    pop = se$POP_ESTIMATE_2018,
    ## vars ##
    # income
    income = se$Median_Household_Income_2018,
    # density
    density = se$Density.per.square.mile.of.land.area...Population,
    # transit
    transit = se$transit_scores...population.weighted.averages.aggregated.from.town.city.level.to.county,
    # nICU beds
    icu_beds = se$ICU.Beds
)

# filter for IL
il <- se[se$state == "IL", ]

# remove all rows with any na
se <- se[complete.cases(se), ]

## normalize scores

# density
maxDensity <- max(se$density, na.rm=TRUE)
se$ndensity <- sapply(se$density, function(x) x/maxDensity)

# income
maxIncome <- max(se$income, na.rm=TRUE)
se$nincome <- sapply(se$income, function(x) x/maxIncome)

# transit
maxTransit <- max(se$transit, na.rm=TRUE)
se$ntransit <- sapply(se$transit, function(x) x/maxTransit)

# nICU beds
maxICU <-  max(se$icu_beds, na.rm=TRUE)
se$nicu_beds <- sapply(se$icu_beds, function(x) x/maxICU)

# normalized scores
ns <- data.frame(
    density=se$ndensity,
    income=se$nincome,
    transit=se$ntransit,
    icu=se$nicu_beds
)

# raw scores
rs <- data.frame(
    density=se$density,
    income=se$income,
    transity=se$transit,
    icu=se$icu_beds
)

##### mortality

# case-mortality table
d <- read.csv("../modelInput/ILCaseAndMortalityV1.csv", stringsAsFactors = FALSE)
d$date = as.Date(d$dateRep,format='%m/%d/%y')
d$countryterritoryCode <- sapply(d$countryterritoryCode, as.character)
d$countryterritoryCode <- sub("840", "", d$countryterritoryCode)

codeToName <- unique(data.frame("countyCode" = d$countryterritoryCode, "countyName" = d$countriesAndTerritories))
countries <- unique(d$countryterritoryCode)

##### mobility

# Read google mobility
source("./read-mobility.r")
mobility <- read_google_mobility(countries=countries, codeToName=codeToName)

# basic impute values for NA in google mobility
# see: https://github.com/ImperialCollegeLondon/covid19model/blob/v6.0/base-usa.r#L87-L88
for(i in 1:ncol(mobility)){
  if (is.numeric(mobility[,i])){
    mobility[is.na(mobility[,i]), i] <- mean(mobility[,i], na.rm = TRUE)
  }
}

#### regress mobility on soc-ec
#### mortality per-capita on soc-ec


#! /usr/bin/env Rscript

library(muHVT)
library(MASS)

args <- commandArgs(trailing = TRUE)
D <- as.integer(args[1])
n <- as.integer(args[2])
N <- as.integer(args[3])
print(D)
print(n)
print(N)

generate_standard_normal_voronoi <- function(N, d, n_clusters)
    {

    mu <- c(rep(0, d))
    sigma <-  diag(d)
    samples <- mvrnorm(N, mu = mu, Sigma = sigma )

    hvt.results <- list()
    hvt.results <- muHVT::HVT(samples,
                          nclust = n_clusters,
                          depth = 1,
                          quant.err = 0.2,
                          projection.scale = 10,
                          normalize = T,
                          distance_metric = "L2_Norm",
                          error_metric = "mean")
    hvt.results[[3]][['summary']]['n'] <- hvt.results[[3]][['summary']]['n']/N
    list(hvt.results[[3]][['summary']], samples)
}

set.seed(Sys.time())
result = generate_standard_normal_voronoi(N=N, d=D, n_clusters=n)
rsamples <- result[[2]]
quantized_samples <- result[[1]]

write.csv(quantized_samples, 'grid.dat',row.names = FALSE)


score <- function(input) {
    if ((input[13]) <= (9.845000267028809)) {
        if ((input[6]) <= (6.959500074386597)) {
            if ((input[7]) <= (96.20000076293945)) {
                var0 <- 25.093162393162395
            } else {
                var0 <- 50.0
            }
        } else {
            var0 <- 38.074999999999996
        }
    } else {
        if ((input[13]) <= (15.074999809265137)) {
            var0 <- 20.518439716312056
        } else {
            var0 <- 14.451282051282046
        }
    }
    if ((input[13]) <= (9.650000095367432)) {
        if ((input[6]) <= (7.437000036239624)) {
            if ((input[8]) <= (1.47284996509552)) {
                var1 <- 50.0
            } else {
                var1 <- 26.7965317919075
            }
        } else {
            var1 <- 44.21176470588236
        }
    } else {
        if ((input[13]) <= (17.980000495910645)) {
            var1 <- 19.645652173913035
        } else {
            var1 <- 12.791919191919195
        }
    }
    return(((var0) + (var1)) * (0.5))
}


##########################################################
# Functions to sample from the conditional distributions
##########################################################
library(MASS)
library(mvtnorm)
source('ars_alpha.r')
source('ars_beta.r')

# Chinese Restaurant Process with auxiliary tables (Neal's algorithm 8)
sample_z <- function(u, A, alpha, z, mu_ar, S_ar, mu_a0, R_a0, beta_a0, W_a0){
  m <- 3 # number of auxiliary tables to approximate the infinite number of empty tables

  n <- tabulate(z)
  K <- length(unique(z))
  D <- dim(A)[1]
  R_a0_inv <- solve(R_a0)
  W_a0_inv <- solve(W_a0)

  # Compute likelihood for every table
  logprobs <- rep(NA, K+m)
  for(k in 1:K){
    logp <- log(n[k]-as.numeric(z[u]==k))
    logp <- logp + mvtnorm::dmvnorm(A[,u], mean=mu_ar[,k,drop=FALSE], sigma=ginv(S_ar[,,k]), log=TRUE)
    logprobs[k] <- logp
  }

    # Create m auxiliary tables from the base distribution
    aux.tables.mean <- t(mvrnorm(m, mu_a0, R_a0_inv))
    aux.tables.covariance <-  rWishart(m, max(beta_a0,D), W_a0/beta_a0)

    # If last point in cluster, re-use its parameters for the auxiliary table so that
    # it has some probability of staying
    if (n[z[u]]==1){
      aux.tables.mean[,1] <- mu_ar[,z[u], drop=FALSE]
      aux.tables.covariance[,,1] <- S_ar[,,z[u]]
    }

    # Compute likelihood for auxilary table
    for(k in 1:m){
      logp <- log(alpha/m)
      logp <- logp + mvtnorm::dmvnorm(A[,u], mean=aux.tables.mean[,k], sigma=as.matrix(aux.tables.covariance[,,k]), log=TRUE)
      logprobs[K+k] <- logp
    }

  # normalize probabilities to avoid numerical underflow
  probs <- logprobs-max(logprobs)
  probs <- exp(probs)
  probs <- probs/sum(probs)

  # Choose table
  chosen <- base::sample(1:(K+m), 1, prob=probs)

  # Re-label tables
  ##########################################
  # if auxiliary table is chosen, assign label K+i-th to this new table
  if(chosen>K){
    mu_ar[,K+1] <- aux.tables.mean[, chosen - K]
    S_ar[,,K+1] <- solve(aux.tables.covariance[,, chosen - K])
    z[u] <- K+1
  }
  else{
    z[u] <- chosen
  }

  # if old cluster is empty, shift right tables to the left
  # do it only if DP is used (m>0)
  n <- tabulate(z)
  if(any(n==0)){
    empty <- which(n==0)
    right <- (empty+1):(K+1)
    mu_ar[,(empty:K)] <- mu_ar[,(empty+1):(K+1)]
    S_ar[,,(empty:K)] <- S_ar[,,(empty+1):(K+1)]
    z[z>empty] <- z[z>empty] - 1
  }

  if( max(z) != length(unique(z)) ){
    stop("Some cluster is not being used")
  }

  return(list(z=z,
              mu_ar=mu_ar,
              S_ar=S_ar))
}

########################################################
# Component parameters
########################################################
# Cluster mean
sample_mu_ar <- function(A_r, S_ar, mu_a0, R_a0){
  n <- dim(A_r)[2]

  # If nobody in the cluster sample from prior
  if (n == 0){
    return(mvrnorm(1, mu_a0, solve(R_a0)))
  }

  ar_mean <- rowMeans(A_r)
  Lambda_post <- R_a0 + n*S_ar
  Sigma_post <- solve(Lambda_post)
  mu_post <- Sigma_post %*% ((R_a0 %*% mu_a0) + n*(S_ar%*%ar_mean))
  return(mvrnorm(1, mu_post, Sigma_post))
}

# Cluster precision
sample_S_ar <- function(A_r, mu_ar_k, beta_a0, W_a0){
  #
  # Sample attributes covariance matrix of cluster r
  # from its conditional probability
  #
  n <- dim(A_r)[2]
  D <- dim(A_r)[1]

  # If nobody in the cluster sample from prior
  if (n == 0){
    # unfortunately wishart implementation does not accept dof > F-1
    # but dof >= F
    # This will only affect when the cluster is empty.
    df <- max(beta_a0, D)
    return(rWishart(1, df, solve(W_a0)/beta_a0))
  }
  # If only one point, scatter is just this product
  if(n==1){
    scatter_matrix <- (A_r-mu_ar_k)%*%t(A_r-mu_ar_k)
  }
  if(n > 1){
    scatter_matrix <- cov(t(A_r-c(mu_ar_k)))*(dim(A_r)[2]-1)
  }

  wishart_dof_post <- beta_a0 + n
  #wishart_S_post <- solve(beta_a0*W_a0 + scatter_matrix)
  wishart_S_post <- ginv(beta_a0*W_a0 + scatter_matrix)
  return(rWishart(1, wishart_dof_post, wishart_S_post)[,,1])
}

########################################################
# Hyperparameters
########################################################

# Hyper-mean of cluster means
sample_mu_a0 <- function(Lambda_a, mu_a, mu_ar, R_a0){
  #
  # Samples mean of gaussian hyperprior placed over clusters centroids
  #
  K <- dim(mu_ar)[2]
  mean_ar = rowMeans(mu_ar)
  Lambda_post = Lambda_a + K*R_a0
  Sigma_post = solve(Lambda_post)
  mu_post = Sigma_post %*% (Lambda_a %*% mu_a) + K*(R_a0 %*% mean_ar)
  return(mvrnorm(1, mu_post, Sigma_post))
}

# Hyper-precision of cluster means
sample_R_a0 <-function(Sigma_a, mu_ar, mu_a0){
  #
  # Samples precision of gaussian hyperprior placed over clusters centroids
  #
  K <- dim(mu_ar)[2]
  D <- dim(mu_ar)[1]
  # Can't use the trick cov(t(mu_ar-mu_a0))*(K-1) when there is only one cluster
  scatter_matrix <- 0
  for(i in 1:K){
    scatter_matrix <- scatter_matrix + (mu_ar[,i]-mu_a0)%*%t(mu_ar[,i]-mu_a0)
  }
  wishart_dof_post = D + K
  wishart_S_post = solve(D*Sigma_a + scatter_matrix)
  return(as.matrix(rWishart(1, wishart_dof_post, wishart_S_post)[,,1]))
}

# Hyper-scale of cluster covariances
sample_W_a0 <- function(Lambda_a, S_ar, beta_a0){
  #
  # Sample base covariance of attributes (hyperparameter)
  #
  K <- dim(S_ar)[3]
  D <- dim(S_ar)[1]
  # TODO: why apply does not work properly?
  #scatter_matrix <- apply(S_ar, 3, sum)
  scatter_matrix <- 0
  for (i in 1:dim(S_ar)[3]){
    scatter_matrix <- scatter_matrix + S_ar[,,i]
  }
  wishart_dof_post = D + K*beta_a0
  wishart_S_post = solve(D * Lambda_a + beta_a0*scatter_matrix)
  return(as.matrix(rWishart(1, wishart_dof_post, wishart_S_post)[,,1]))
}

# Hyper-dof of cluster covariances
sample_beta_a0 <- function(S, W, init=4){
  # Sample the degrees of freedom of the Wishart
  # given a scale matrix W and some observed precision matrices S
  ars.sample_beta_a0(S, W, init=init)
}


# set options
options(browser = "C:/Users/jinman/firefox/firefox.exe")
library(nlme)
set.seed(1)

# clear memory
rm(list =ls())

# define functions
get_sd <- function(x) {
    sqrt(var(x))
}

# load data
data <- read.csv("data.csv")

# transform data
data$SampleDate <- as.Date(data$SampleDate, format = "%m/%d/%Y")
data$Year <- as.numeric(format(data$SampleDate, "%Y"))
data$Month <- as.numeric(format(data$SampleDate, "%m"))
data$Result <- log10(data$Result + 0.01)

# subset data
# subset by year
# data <- data[data$Year > 2016, ]
# subset by month
start <- 10
stop <- 4
data <- data[data$Month >= start | data$Month <= stop, ]
data <- data[c("ParentProject", "StationCode", "SampleDate", "Result", "Year")]
# Removed 309TEM because no data
sites <- c("309GAB", "309NAD", "309ALG", "309ALD", "309JON", "309TEH",
           "309TDW", "309OLD", "309ASB", "309MER", "309ESP", "309RTA")
data <- data[data$StationCode %in% sites, ]

# run model
mod <- lme(Result ~ Year, data = data, random = ~ 1 | StationCode)

# check residuals
# plot(mod)

# create parameter tables
ns_wide <- tapply(data$Result, list(data$StationCode, data$Year), length)
ns_wide <- as.data.frame(ns_wide)
ns_wide <- cbind(StationCode = row.names(ns_wide), ns_wide)

means_wide <- tapply(data$Result, list(data$StationCode, data$Year), mean)
means_wide <- as.data.frame(means_wide)
means_wide <- cbind(StationCode = row.names(means_wide), means_wide)

sds_wide <- tapply(data$Result, list(data$StationCode, data$Year), get_sd)
sds_wide <- as.data.frame(sds_wide)
sds_wide <- cbind(StationCode = row.names(sds_wide), sds_wide)

#>>>>>>> Tuning knobs >>>>>>>
# tuning knob for baseline
baseline_years <- 5
means_wide_sub <- means_wide[, (ncol(means_wide) - baseline_years):ncol(means_wide)]
baseline_means <- apply(means_wide_sub, 1, mean, na.rm = TRUE)
baseline <- mean(baseline_means)

# tuning knobs for final goals
end_goal <- 11 # NTU
total_years <- 20
log_end_goal <- log10(end_goal + 0.01)
rate <- (log_end_goal / baseline)^(1 / total_years) - 1

# tuning knob for interim goals
no_years <- 5

# tuning knob for sample size
n_per_month <- 1
n <- ((12 - start + 1) + stop) * n_per_month

# tuning knob for number of iterations
N <- 10000

#<<<<<<< Tuning knobs <<<<<<<<
pvals <- rep(NA, N)
for (i in 1:N) {
    # calculate interim goal
    log_goal <- baseline * (1 + rate)^no_years

    # generate means
    gen_means_wide <- sapply(baseline_means, seq, log_goal, length.out = no_years)
    gen_means_wide <- as.data.frame(t(gen_means_wide))
    names(gen_means_wide) <- paste0("y", 1:no_years)
    gen_means_wide <- cbind(StationCode = means_wide[, 1], gen_means_wide)

    # generate sds
    sds_wide_sub <- sds_wide[, (ncol(sds_wide) - baseline_years):ncol(sds_wide)]
    baseline_sds <- apply(sds_wide_sub, 1, mean, na.rm = TRUE)
    gen_sds_wide <- sapply(baseline_sds, rep, no_years)
    gen_sds_wide <- as.data.frame(t(gen_sds_wide))
    names(gen_sds_wide) <- paste0("y", 1:no_years)
    gen_sds_wide <- cbind(StationCode = sds_wide[, 1], gen_sds_wide)
    # attenuate sd over time proportional to mean (trickiest part)
    normalization <- apply(gen_means_wide[-1], 2, "/", gen_means_wide$y1)
    gen_sds_wide[-1] <- gen_sds_wide[-1] * normalization

    # reshape generated parameters to long
    gen_means <- reshape(gen_means_wide,
                direction = "long",
                v.names = "mean",
                times = names(gen_means_wide)[2:ncol(gen_means_wide)],
                timevar = "Year",
                varying = list(2:ncol(gen_means_wide)))
    gen_means$id <- NULL
    gen_sds <- reshape(gen_sds_wide,
                direction = "long",
                v.names = "sd",
                times = names(gen_sds_wide)[2:ncol(gen_sds_wide)],
                timevar = "Year",
                varying = list(2:ncol(gen_sds_wide)))
    gen_sds$id <- NULL

    # generate data
    stub <- merge(gen_means, gen_sds, by = c("StationCode", "Year"))
    stub$Year <- as.numeric(substr(stub$Year, 2, 4))

    if (n == 1) {
        gen_data_wide <- mapply(rnorm, n, stub$mean, stub$sd)
        gen_data_wide <- cbind(stub, "1" = gen_data_wide)
    } else {
        gen_data_wide <- t(mapply(rnorm, n, stub$mean, stub$sd))
        gen_data_wide <- cbind(stub, gen_data_wide)
    }

    # reshape generated data to long
    gen_data <- reshape(gen_data_wide,
                        direction = "long",
                        v.names = "Result",
                        varying = list(5:ncol(gen_data_wide)))

    # run model on generated data
    gen_mod <- lme(Result ~ Year, data = gen_data, random = ~ 1 | StationCode)
    pval <- summary(gen_mod)$tTable["Year", "p-value"]
    pval <- round(pval, 4)

    pvals[i] <- pval
}
# calculate power
P <- sum(pvals <= 0.05) / N
P * 100


library(dslabs)
data(olive)
head(olive)

palmatic <- olive$palmitic
palmitoleic <- olive$palmitoleic

plot(palmatic, palmitoleic)

boxplot(palmatic, palmitoleic)

boxplot(palmatic~region, data=olive)


#!/usr/bin/env Rscript
# @Author: vargash1
# @Name:   Vargas, Hector
# @Email:  vargash1@wit.edu
# @Date:   2015-07-31 00:34:02
# @Last Modified by:   vargash1
# @Last Modified time: 2015-08-02 00:22:43

library(shiny)

# Define server logic required to draw a histogram
shinyServer(function(input, output) {
	# ---------------------------------------------
	# renders plot to main page
  	output$Plot <- renderPlot({
	  	# read in csv
	  	data_in <<- read.csv("input.csv")
	  	attach(data_in)

	  	# react to user variable change
	  	l <<- list(SEASON,AGE,DIS,ACC,SURG,FEVER,ALCHOL,SMOKE,SIT)
	  	slt <- as.integer(input$select)
	  	targ <- l[[slt]]

	  	# simple way to make our labels pretty
	  	lbl <- list("Season Analysis was performed (Winter: -1, Spring: -0.33, Summer: 0.33, Fall: 1)",
	  		"Age at time of Analysis (18-36)",
	  		"Childish Diseases (Yes:0 , No:1)",
	  		"Accident/Serious Trauma (Yes:0 , No:1)",
	  		"Surgical Intervention (Yes:0 , No:1)",
	  		"High Fevers in the Last Year (< 3 months ago: -1, > 3 months ago: 0, No: 1)",
	  		"Frequency of Alcohol Consumption (Several per Day, Every Day, Several per Week,Once a Week, Hardly)",
	  		"Smoking Habit (Never: -1, Occasional: 0, Daily: 1)",
	  		"Hours Spent Sitting Daily(0-16)")
		x_lb <- lbl[slt]

	  	# linear reg and plot to page
	  	a <- lm(OUT~targ)
	  	plot(targ,OUT,
	    	main = "Linear Regression on Feritility of Males",
	    	xlab = x_lb,
	    	ylab = "Diagnosis, Normal(0) Altered(1)")
	    abline(a)
	  })
	# ---------------------------------------------
	# correlation variables
	output$cofvar <- renderUI({
		tmp1 <- as.integer(input$select)
		tmp2 <- l[[tmp1]]
		tmp2_cor <- cor(tmp2,OUT)
		withMathJax(
			sprintf("$$r =  %.03f $$",tmp2_cor),
			sprintf("$$r^{2} =  %.03f$$",tmp2_cor^2)
		)
	})
	# ---------------------------------------------
	# generate summary of data of selected variable
	output$summary <- renderPrint({
		tmp1 <- as.integer(input$select)
		tmp2 <-	l[[tmp1]]
		summary(tmp2)
	})
	# ---------------------------------------------
	# output formula using LaTeX
	output$lrformula <- renderUI({
		tmp1 <- as.integer(input$select)
		tmp2 <- l[[tmp1]]
		lmodel <- lm(OUT~tmp2)
		x <- lmodel$coefficients[1]
		y <- lmodel$coefficients[2]
		withMathJax(sprintf("$$f = %.03f + %.03f x$$",x,y))
	})
	# ---------------------------------------------
	# print out dataset
	output$dataset <- renderPrint({
		print(data_in)
	})
	# ---------------------------------------------
	# About me
	output$aboutme <- renderUI({
		withMathJax(
			helpText("Hector Vargas"),
			helpText("Computer Science 2016 "),
			helpText("Final Project for MATH505 "),
			helpText("Professor: Gary Simundza ")
		)
	})
})


select.knots <- function(t, knots = 10, p = 3, option = "equally-spaced") {
  qs <- seq(0, 1, length = knots + 1)
  max_t <- max(t)
  min_t <- min(t)
  range_t <- max_t - min_t

  min_t <- min_t - range_t * 0.001 # follow Simon Wood's implementation
  max_t <- max_t + range_t * 0.001 #

  if (option == "equally-spaced") {
    knots <- (max_t - min_t) * qs + min_t
  }
  if (option == "quantile") {
    loc_max <- which.max(t)
    loc_min <- which.min(t)
    s <- t + rnorm(length(t)) * range_t / 100
    s[loc_max] <- t[loc_max]
    s[loc_min] <- t[loc_min]
    t <- s
    knots <- as.vector(quantile(t, qs))
  }

  K <- length(knots)
  knots_left <- 2 * knots[1] - knots[p:1 + 1]
  knots_right <- 2 * knots[K] - knots[K - (1:p)]

  if (p > 0) {
    return(c(knots_left, knots, knots_right))
  }
  if (p == 0) {
    return(knots)
  }
}


#Preenchimento com Regrssão
setwd('/home/lucas/Dev/git/mlclass-private/01_Preprocessing')
diaInfo <- read.csv(file = 'diabetes_dataset.csv')
diaAva <- read.csv(file = 'diabetes_app.csv')
meanDia1 <- c()
meanDia0 <- c()
maxValue <- c()
minValue <- c()
sdDia0 <- c()
sdDia1 <- c()
medianDia0 <- c()
medianDia1 <- c()

setDia1 <- diaInfo[which(diaInfo$Outcome == 1),]
setDia0 <- diaInfo[which(diaInfo$Outcome == 0),]
corDia1 <- c()
corDia0 <- c()
corDia1 <- cor(setDia1,use="complete.obs")
corDia0 <- cor(setDia0,use="complete.obs")
lm(setDia1[,2] ~ setDia1[,5], data=setDia1)
pairs(setDia1)
# pairs(setDia0)

for(categ in 1:8){
  meanDia1[categ] <- mean(setDia1[,categ],na.rm = TRUE)
  meanDia0[categ] <- mean(setDia0[,categ],na.rm = TRUE)
  maxValue[categ] <- max (diaInfo[,categ],na.rm = TRUE)
  minValue[categ] <- min (diaInfo[,categ],na.rm = TRUE)
  sdDia1  [categ] <- sd  (setDia1[,categ],na.rm = TRUE)
  sdDia0  [categ] <- sd  (setDia0[,categ],na.rm = TRUE)
  medianDia1[categ] <- median(setDia1[,categ],na.rm = TRUE)
  medianDia0[categ] <- median(setDia0[,categ],na.rm = TRUE)
}
weight <- c()
weight[1]<-2        #Pregnancies
weight[2]<-2        #Glucose
weight[3]<-1        #BloodPressure
weight[4]<-1        #SkinThickness
weight[5]<-1        #Insulin
weight[6]<-2        #BMI
weight[7]<-0       #Pedigree
weight[8]<-5        #Age

for(i in 1:572){
  actual <- diaInfo[i,]
  if(actual[9] == 1){
    if(is.na(actual[5])){
      diaInfo[i,5] = -52.162 + actual[2]*1.769
      print(diaInfo[i,5])
    }

  }
  for(categ in 1:8){
    if(is.na(actual[categ])|| is.null(actual[categ]))
    {
      if(actual[9]==1) {
        actual[categ] = meanDia1[categ]#rnorm(1, mean = meanDia1[categ], sd = sdDia1[categ])
      }
      else {
        actual[categ] = meanDia0[categ]#rnorm(1, mean = meanDia0[categ], sd = sdDia0[categ])
      }
      diaInfo[i,categ] = actual[categ]
    }
    if(actual[9]==0)
    {
      # if(!is.na(actual[2])&&actual[2]>170.0) {
      #   diaInfo[i,2]=actual[2]-30
      # }
      # if(!is.na(actual[7])&&actual[7]>1.5) {
      #   diaInfo[i,7] = diaInfo[i,7] - 1
      # }
      # if(!is.na(actual[5])&&actual[5]>400) {
      #   diaInfo[i,5] = diaInfo[i,5] - 200
      # }
    } else {

    }
  }
}

normalizeData = function(df) {
  for(i in 1:8){
    df[,i] <- (df[,i]/maxValue[i])*weight[i]
  }
  return(df)
}

dfAva <- normalizeData(diaAva)
dfInfo <- normalizeData(diaInfo)

write.csv(dfAva[1:8], file = 'Valuator.csv', row.names = FALSE)
write.csv(dfInfo[1:9], file = 'Output.csv', row.names = FALSE)


rm(list = ls())
library(gstat)
library(sp)
args = commandArgs(trailingOnly=TRUE)

tic <- Sys.time()
{

  #filename = "F:/PersonalProject/Stone/UIForm/From/bin/x64/Debug/factorialkriging/DetrendingDSM.txt"
  filename = args[1]
  station = read.table(filename, header = FALSE, col.names = c("x", "y", "z"))
  siterows = nrow(station)

  spsite = station
  coordinates(spsite) = ~x + y
  print("computing variogram")
  site.vgm = gstat::variogram(z ~ 1, spsite, width = 0.01, cutoff = 3.0)
  vgmrows = nrow(site.vgm)
  print("Finish Compute variogram")
  #filename = "F:/PersonalProject/Stone/UIForm/From/bin/x64/Debug/vgm/ho1S4RPdtvgm1cm.txt"
  filename = args[2]
  fp = file(filename, "w")
  cat("np dist gamma\n", file = fp, sep = "")
  for(index in 1:vgmrows)
  {
    cat(site.vgm$np[index], " ",
        formatC(site.vgm$dist[index], digits = 15, width = -1, format = "fg"), " ",
        formatC(site.vgm$gamma[index], digits = 15, width = -1, format = "fg"), "\n",
        file = fp, sep = "")

  }
  close(fp)

}
toc <- Sys.time()
comp.time <- toc - tic
lznr.fit = fit.variogram(site.vgm, model = vgm(0.01, "Sph", 2.0,  add.to = vgm(0.01, "Sph", 1, nugget = 0.000001)))
lznr.fit
filename = args[3]
capture.output(lznr.fit, file = filename)


### Fuller: Generates point estimates and standard errors
###            Must run ivmodel before you run this code
### INPUT: ivmodel, an object from ivmodel() function
###        b, adjustment by Fuller
###        beta0, a vector (or scalar) of null values for testing and p-values
###        alpha, significance level for confidence intervals
### OUTPUT: a list of point estimate, standard error, test statistic, and p-value
Fuller = function(ivmodel,
                  beta0=0,alpha=0.05,b=1,
                  manyweakSE=FALSE,heteroSE=FALSE,clusterID=NULL) {
  # Error checking
  if(class(ivmodel) != "ivmodel") {
    print("Fuller: You must supply an ivmodel class. See ivmodel function for details")
	return(NULL)
  }
  if(b <= 0) {
    print("Fuller: Fuller adjustment cannot be less than 0")
	return(NULL)
  }

  # Extract objects from ivmodel
  Yadj = ivmodel$Yadj; Dadj = ivmodel$Dadj; Zadj = ivmodel$Zadj; ZadjQR = ivmodel$ZadjQR

  # Value of k for LIML
  LIMLMatrix1 = matrix(0,2,2)
  LIMLMatrix1[1,1] = sum(Yadj^2)
  LIMLMatrix1[1,2] = LIMLMatrix1[2,1] = sum(Dadj * Yadj)
  LIMLMatrix1[2,2] = sum(Dadj^2)

  LIMLMatrix2 = matrix(0,2,2); projYadj = qr.resid(ZadjQR,Yadj); projDadj = qr.resid(ZadjQR,Dadj)
  LIMLMatrix2[1,1] = sum(projYadj^2)
  LIMLMatrix2[1,2] = LIMLMatrix2[2,1] = sum(projDadj * projYadj)
  LIMLMatrix2[2,2] = sum(projDadj^2)

  kLIML = eigen(LIMLMatrix1 %*% invTwobyTwoSymMatrix(LIMLMatrix2))$values[2]
  kFuller = kLIML - b/(ivmodel$n - ivmodel$L - ivmodel$p)
  output = KClass(ivmodel,k=kFuller,beta0=beta0,alpha=alpha,manyweakSE=manyweakSE,heteroSE=heteroSE,clusterID=clusterID)

  # Package output
  rownames(output$point.est) = rownames(output$std.err) = rownames(output$test.stat) = rownames(output$ci) = rownames(output$p.value) = NULL
  return(c(output,list(k=kFuller)))
}


###############################################################################
# "Infection Rate Models for COVID-19:
#  Model Risk and Public Health News Sentiment Exposure Adjustments"
#
#  Ioannis Chalkiadakis, Kevin Hongxuan Yan, Gareth W. Peters, Pavel V. Shevchenko
#
#  Kevin Hongxuan Yan
#  March 2021
###############################################################################

rm(list=ls(all=TRUE))

library(methods)
library(rstan)

cat("Stan version:", stan_version(), "\n")
stanmodelcode <- "

#### define GP function
functions {

real normal_generalized_poisson_log(int y, real theta, real lambda, real sigob, real u, real b1) {
    return (log(theta)
           + (y - 1) * log(theta + y * lambda)
           - lgamma(y + 1)
           - y * lambda
           - theta)*(y<=200)
           +(normal_lpdf(y|theta,sigob))*(y>200)
		   +log(1-normal_cdf(u*-0.00000005,u,0.01))*(b1<u*-0.00000005);   #### +log(b0>0.08*u); (b0>0.08*u)
  }

}

#### define our data, integer value
data {
int<lower=0> N;
int y[N];
real E[N];
}

#### define parameters
parameters {

real lambda;
real u;
real b1;
real b3;
real<lower=0> sig2;
vector[N] e;
real sigob;
}

#### define some parameters which is the function of other parameters
transformed parameters {
vector[N] mu;

### define the mean function
#mu[1] <- exp(u*exp(-b0)+e[1]);

mu[1] <- y[1];  ## not tested

  for (n in 2:N) {

      mu[n] <- (mu[n-1]^2)*exp(u+b1*mu[n-1]+e[n])/(b3+mu[n-1]);

	  }

}

##### define piror and likelihood function
model {
lambda~uniform(-1,1);
u ~ normal(0.1,0.01);
b1 ~ normal(-0.0000005,0.000000001);
b3 ~ normal(0,0.000001);
sig2 ~  gamma(1,1);
e~normal(0,sig2);
sigob ~ uniform(100,1100);

for (j in 1:N) {

y[j] ~ normal_generalized_poisson( mu[j]*E[j], lambda, sigob,u,b1);
}

}

"

######

####### read new data Y
setwd("./covid19modelrisk/output/forecast")

  y=read.csv("COVID-19_confirmed__Germany.csv")
##  y=read.csv("COVID-19_confirmed__Italy.csv")
##  y=read.csv("COVID-19_confirmed__Japan.csv")
##  y=read.csv("COVID-19_confirmed__Spain.csv")
##  y=read.csv("COVID-19_confirmed__United Kingdom.csv")
##  y=read.csv("COVID-19_confirmed__US.csv")
##  y=read.csv("COVID-19_confirmed_Australia.csv")

y=y[,2]

E=rep(1,length(y))

N=length(y)
dat <- list(N = N, y = y,E=E)

#### initial values
inits =list(list(lambda=0,u=0.1,b1=-0.0000005,b3=0,sig2=0.01,e=rep(0.01,N),sigob=1000))  ### 134

fit <- stan(model_code = stanmodelcode, model_name = "example",init =inits,
data = dat, warmup=4000,iter = 40000, chains = 1, seed=999,thin=1)
print(fit,digits = 4)

Epars_m <- apply( as.data.frame(fit@sim[[1]][[1]])[4001:40000,(6+N):(5+2*N)] , 2 , mean )

Epars_5 <- apply( as.data.frame(fit@sim[[1]][[1]])[4001:40000,(6+N):(5+2*N)] , 2 , quantile, probs=0.05 )

Epars_9 <- apply( as.data.frame(fit@sim[[1]][[1]])[4001:40000,(6+N):(5+2*N)] , 2 , quantile, probs=0.95 )

Epars_m[1]=1
Epars_5[1]=1
Epars_9[1]=1

####################  trace plot

traceplot(fit, pars=c("u","b1","b3"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)

traceplot(fit, pars=c("lambda","sig2","sigob"), inc_warmup = T,  nrow = 3, ncol = 1, window = NULL, include = TRUE)

##################   plot 30/45/60/   length(y)

#  Germany Italy Japan Spain UK US Australia

m=length(y)

newx=c(1:m)
par(cex.axis=2.5,cex.lab=2.5,cex.main=2.5,mar=c(5, 5, 3, 0.5))
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main="In-sample fit results of M5 model for Germany",pch=19)
par(new=TRUE)

polygon(c(rev(newx), newx), c(rev(Epars_9[1:m]), Epars_5[1:m]), col = "grey80", border = NA)

lines(newx,Epars_9[1:m], lty = 'dashed', col = 'red',lwd = 2)
lines(newx, Epars_5[1:m], lty = 'dashed', col = 'red',lwd = 2)
par(new=TRUE)
plot(y[1:m],ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main="In-sample fit results of M5 model for Germany",pch=19)
par(new=TRUE)
plot.ts(Epars_m[1:m],col="red",ylim=c(min(y[1:m]),max(y[1:m],Epars_9[1:m])),ylab="Count",xlab="Time",main="In-sample fit results of M5 model for Germany",lwd = 2)

#############################################################
n=length(y)

u=0.1
b1=-0.0000005
b3=0

n=length(y)

x=c()
x[1]=100
for (i in 1:(n-1) ){

x[i+1]=((x[i]^2)*exp(u+b1*x[i]))/(b3+x[i])
}
x=round(x)
x

plot(y,ylim=c(min(x),max(x)))
par(new=TRUE)
plot(x,col="red",ylim=c(min(x),max(x)))

###############################################################################
## u=0.14,b1=-0.00000009, b3=5
# u ~ normal(0,1);
# b1 ~ normal(0,0.0000001);
# b3 ~ normal(0,10);

### Germany
u=0.14
b1=-0.0000009
b2=0.4

## Italy
u=0.24
b0=0.03#u*0.08 ###

## Japan
u=0.05
b0=0.0055

## Spain
u=0.3
b0=0.037

## UK
u=0.3
b0=0.037

## US
u=0.1
b0=0.0067

## AU
u=0.04
b0=0.004


for (line in readLines(tail(commandArgs(), n=1))) {
  cat(sapply(strsplit(line, ";"), function(s) {
    n <- as.integer(s[1])
    d <- sapply(strsplit(s[2], " ")[[1]], as.integer)
    c <- sum(d[1:n])
    m <- max(0, c)
    for (i in (n+1):length(d)) {
      c <- c - d[i-n] + d[i]
      m <- max(m, c)
    }
    m
  }), sep="\n")
}


#ПИ19-3 Деменчук Георгий ДЗ 3
#install.packages('lmtest')
library(lmtest)

data <- read.csv(file = '/Users/demg/Projects/FA/Course III/ECONOMETRICS/task3/data.csv', sep = ";")
data
y = data$Объем.денежных.накоплений.в.РФ.миллиард.руб...y.
x1 <- data$Сводные.данные.о.продаже.наличной.иностранной.валюты.кредитными.организациями.физическим.лицам..x1.
x2 <- data$Курс.рубля.к.доллару.США..x2.
x3 <- data$Цена.нефти.марки..Юралс...x3.
x4 <- data$Динамика.потребительских.цен.по.группам.товаров.и.услуг..месяц.к.соответствующему.месяцу.предыдущего.года......x4.

model <- lm(y ~ x1 + x2 + x3 +x4, data = data)
summary(model)

summary(model)$coefficient

confint(model)


library(dplyr)
library(readr)
library(tidyr)
library(caret)

data_train <- read.csv('./data/processed/processed_train.csv')

# use the right folding pattern
source("./scr/my_folds.r")

# Preprocessing steps
pre_proc <- c('center', 'scale')

# Create reusable trainControl object: myControl
fitControl <- trainControl(
    summaryFunction = twoClassSummary,
    classProbs = TRUE,
    verboseIter = TRUE,
    savePredictions = 'final',
    index = my_folds
)

target <- 'brand'
predictors <- names(data_train)[!names(data_train) %in% target]

fit_glmnet_normalized <-
    train(
        data_train[, predictors],
        data_train[, target],
        trControl = fitControl,
        preProc = pre_proc,
        method = 'glmnet',
        metric = 'ROC'
    )
saveRDS(fit_glmnet_normalized, './models/GLMNET_normalized.rds')

# Trying the same model but this time without centering and scaling

fit_glmnet <-
    train(
        data_train[, predictors],
        data_train[, target],
        trControl = fitControl,
        method = 'glmnet',
        metric = 'ROC'
    )

saveRDS(fit_glmnet, './models/GLMNET.rds')


library(plotrix)
x <-  c(21, 62, 10,53)
lbl <-  c("USA","China","Indonesia","India")
pie3D(x,labels = lbl,explode = 0.1, main = "Pie Chart of Most Populous Countries ")


 DSYGST Example Program Results

 Eigenvalues
    -2.2254 -0.4548  0.1001  1.1270


## Data analytics question and Analysis
######################################################
## A large HMO wants to know what patient and physician factors are most related to
## whether a patient’s lung cancer goes into remission after
## treatment as part of a larger study of treatment outcomes and quality of life in patients with lunger cancer.
##
## Using CancerSurvival xl (coverting it to csv) data
## Name ## Mayukh Mukhopadhyay
## Reference ## http://stats.idre.ucla.edu/other/mult-pkg/introduction-to-generalized-linear-mixed-models/
###################################################################

install.packages("ggplot2")
install.packages("GGally")
install.packages("reshape2")
install.packages("lme4")
install.packages("compiler")
install.packages("parallel")
install.packages("boot")

require(ggplot2)
require(GGally)
require(reshape2)
require(lme4)
require(compiler)
require(parallel)
require(boot)

cancerdata <- read.csv("~/CancerSurvival.csv")
cancerdata <- within(cancerdata, {
  Married <- factor(Married, levels = 0:1, labels = c("no", "yes"))
  DID <- factor(DID)
  HID <- factor(HID)
})
ggpairs(cancerdata[, c("IL6", "CRP", "LengthofStay", "Experience")])
ggplot(cancerdata, aes(x = CancerStage, y = LengthofStay)) +
  stat_sum(aes(size = ..n.., group = 1)) +
  scale_size_area(max_size=10)

 # il6 crp cancerstage plots
tmp <- melt(cancerdata[, c("CancerStage", "IL6", "CRP")], id.vars="CancerStage")
ggplot(tmp, aes(x = CancerStage, y = value)) +
  geom_jitter(alpha = .1) +
  geom_violin(alpha = .75) +
  facet_grid(variable ~ .) +
  scale_y_sqrt()

  #boxplot
tmp <- melt(cancerdata[, c("remission", "IL6", "CRP", "LengthofStay", "Experience")],
  id.vars="remission")
ggplot(tmp, aes(factor(remission), y = value, fill=factor(remission))) +
  geom_boxplot() +
  facet_wrap(~variable, scales="free_y")

# estimate the model and store results in m for nAGQ = 10
m <- glmer(remission ~ IL6 + CRP + CancerStage + LengthofStay + Experience +
    (1 | DID), data = cancerdata, family = binomial, control = glmerControl(optimizer = "bobyqa"),
    nAGQ = 10)

# BOBYQA (Bound Optimization BY Quadratic Approximation)

# print the mod results without correlations among fixed effects
print(m, corr = FALSE)

# Generalized linear mixed model fit by maximum likelihood (Adaptive Gauss-Hermite Quadrature, nAGQ
#   = 10) [glmerMod]
#  Family: binomial  ( logit )
# Formula: remission ~ IL6 + CRP + CancerStage + LengthofStay + Experience +      (1 | DID)
#    Data: cancerdata
#       AIC       BIC    logLik  deviance  df.resid
#  7397.276  7460.733 -3689.638  7379.276      8516
# Random effects:
#  Groups Name        Std.Dev.
#  DID    (Intercept) 2.015
# Number of obs: 8525, groups:  DID, 407
# Fixed Effects:
#    (Intercept)             IL6             CRP   CancerStageII  CancerStageIII   CancerStageIV
#       -2.05271        -0.05677        -0.02148        -0.41393        -1.00346        -2.33704
#   LengthofStay      Experience
#       -0.12118         0.12009

# estimate the model and store results in m for nAGQ = 50
m <- glmer(remission ~ IL6 + CRP + CancerStage + LengthofStay + Experience +
    (1 | DID), data = cancerdata, family = binomial, control = glmerControl(optimizer = "bobyqa"),
    nAGQ = 50)

# BOBYQA (Bound Optimization BY Quadratic Approximation)

# print the mod results without correlations among fixed effects
print(m, corr = FALSE)

#Generalized linear mixed model fit by maximum likelihood (Adaptive Gauss-Hermite Quadrature, nAGQ
#  = 50) [glmerMod]
# Family: binomial  ( logit )
#Formula: remission ~ IL6 + CRP + CancerStage + LengthofStay + Experience +      (1 | DID)
#   Data: cancerdata
#      AIC       BIC    logLik  deviance  df.resid
# 7397.233  7460.690 -3689.617  7379.233      8516
#Random effects:
# Groups Name        Std.Dev.
# DID    (Intercept) 2.015
#Number of obs: 8525, groups:  DID, 407
#Fixed Effects:
#   (Intercept)             IL6             CRP   CancerStageII  CancerStageIII   CancerStageIV
#      -2.05325        -0.05677        -0.02148        -0.41393        -1.00349        -2.33711
#  LengthofStay      Experience
#      -0.12118         0.12011

# getting confidence intervals (CIs)
se <- sqrt(diag(vcov(m)))
# table of estimates with 95% CI
(tab <- cbind(Est = fixef(m), LL = fixef(m) - 1.96 * se, UL = fixef(m) + 1.96 *
    se))

##                        Est          LL           UL
## (Intercept)    -2.05325039 -3.09521978 -1.011280996
## IL6            -0.05677292 -0.07934869 -0.034197141
## CRP            -0.02148286 -0.04151069 -0.001455033
## CancerStageII  -0.41393231 -0.56242696 -0.265437658
## CancerStageIII -1.00348621 -1.19612106 -0.810851355
## CancerStageIV  -2.33710519 -2.64690344 -2.027306943
## LengthofStay   -0.12118413 -0.18710508 -0.055263171
## Experience      0.12010779  0.06628398  0.173931601

# odds ratios instead of coefficients on the logit scale
exp(tab)

##                       Est         LL        UL
## (Intercept)    0.12831714 0.04526506 0.3637527
## IL6            0.94480860 0.92371778 0.9663810
## CRP            0.97874625 0.95933908 0.9985460
## CancerStageII  0.66104570 0.56982444 0.7668702
## CancerStageIII 0.36659917 0.30236479 0.4444795
## CancerStageIV  0.09660689 0.07087033 0.1316897
## LengthofStay   0.88587083 0.82935658 0.9462361
## Experience     1.12761839 1.06853011 1.1899742

##############multilevel bootstrapping with 100 replicates

sampler <- function(dat, clustervar, replace = TRUE, reps = 1) {
    cid <- unique(dat[, clustervar[1]])
    ncid <- length(cid)
    recid <- sample(cid, size = ncid * reps, replace = TRUE)
    if (replace) {
        rid <- lapply(seq_along(recid), function(i) {
            cbind(NewID = i, RowID = sample(which(dat[, clustervar] == recid[i]),
                size = length(which(dat[, clustervar] == recid[i])), replace = TRUE))
        })
    } else {
        rid <- lapply(seq_along(recid), function(i) {
            cbind(NewID = i, RowID = which(dat[, clustervar] == recid[i]))
        })
    }
    dat <- as.data.frame(do.call(rbind, rid))
    dat$Replicate <- factor(cut(dat$NewID, breaks = c(1, ncid * 1:reps), include.lowest = TRUE,
        labels = FALSE))
    dat$NewID <- factor(dat$NewID)
    return(dat)
}

set.seed(20)
tmp <- sampler(cancerdata, "DID", reps = 100)
bigdata <- cbind(tmp, cancerdata[tmp$RowID, ])

## First we store the estimates from our original model, which we will use as start values for the bootstrap models.
## Then we make a local cluster with 2 nodes (the number of processors on our machine).
## Next, we export the data and load the lme4 package on the cluster.
## Finally, we write a function to fit the model and return the estimates.
## The call to glmer() is wrapped in try because not all models may converge on the resampled data.
## This catches the error and returns it, rather than stopping processing.

f <- fixef(m)
r <- getME(m, "theta")

cl <- makeCluster(2)
clusterExport(cl, c("bigdata", "f", "r"))
clusterEvalQ(cl, require(lme4))
## [[1]]
## [1] TRUE
##
## [[2]]
## [1] TRUE

myboot <- function(i) {
    object <- try(glmer(remission ~ IL6 + CRP + CancerStage + LengthofStay +
        Experience + (1 | NewID), data = bigdata, subset = Replicate == i, family = binomial,
        nAGQ = 1, start = list(fixef = f, theta = r)), silent = TRUE)
    if (class(object) == "try-error")
        return(object)
    c(fixef(object), getME(object, "theta"))
}

#### Execute with your own risk...My laptop with 2 cores and 4GB RAM got blackedout  5 times and returned output after 2 hours
start <- proc.time()
res <- parLapplyLB(cl, X = levels(bigdata$Replicate), fun = myboot)
end <- proc.time()

# shut down the cluster
stopCluster(cl)

# calculate proportion of models that successfully converged
success <- sapply(res, is.numeric)
mean(success)

# combine successful results
bigres <- do.call(cbind, res[success])

# calculate 2.5th and 97.5th percentiles for 95% CI
(ci <- t(apply(bigres, 1, quantile, probs = c(0.025, 0.975))))

##                       2.5%     97.5%
## (Intercept)       -3.61982 -0.985404
## IL6               -0.08812 -0.029664
## CRP               -0.04897  0.006824
## CancerStageII     -0.60754 -0.228019
## CancerStageIII    -1.30217 -0.754609
## CancerStageIV     -2.91414 -2.002643
## LengthofStay      -0.21596 -0.046420
## Experience         0.06819  0.207223
## NewID.(Intercept)  2.03868  2.476366

# All results
finaltable <- cbind(Est = c(f, r), SE = c(se, NA), BootMean = rowMeans(bigres),
    ci)
# round and print
round(finaltable, 3)

##                    Est    SE BootMean   2.5%  97.5%
## (Intercept)     -2.053 0.531   -2.205 -3.620 -0.985
## IL6             -0.057 0.012   -0.059 -0.088 -0.030
## CRP             -0.021 0.010   -0.022 -0.049  0.007
## CancerStageII   -0.414 0.076   -0.417 -0.608 -0.228
## CancerStageIII  -1.003 0.098   -1.043 -1.302 -0.755
## CancerStageIV   -2.337 0.158   -2.460 -2.914 -2.003
## LengthofStay    -0.121 0.034   -0.142 -0.216 -0.046
## Experience       0.120 0.027    0.128  0.068  0.207
## DID.(Intercept)  2.015    NA    2.263  2.039  2.476