6DDA2A7B

{
    "collab_server" : "",
    "contents" : "#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' get mean rainfall bar plot of the input dataset or time series.\n#' \n#' \n#' @param data A list containing different information, should be the result of reading netcdf file using\n#' \\code{\\link{loadNcdf}}, or a time series, with first column the Date, second the value.\n#' Time series can be an ENSEMBLE containning different members. Than the mean value will be given and the range will be given.\n#' @param method A string showing the calculating method of the input time series. More information\n#' please refer to the details.\n#' @param cell A vector containing the locaton of the cell, e.g. c(2, 3), default is \"mean\", representing\n#' the spatially averaged value. Check details for more information.\n#' @param output A string showing the type of the output, if \\code{output = 'ggplot'}, the returned \n#' data can be used in ggplot and \\code{getPreciBar_comb()}; if \\code{output = 'plot'}, the returned data is the plot containing all \n#' layers' information, and can be plot directly or used in grid.arrange; if not set, the data\n#' will be returned.\n#' @param name If \\code{output = 'ggplot'}, name has to be assigned to your output, in order to differentiate\n#' different outputs in the later multiplot using \\code{getSpatialMap_comb}.\n#' @param plotRange A boolean showing whether the range will be plotted.\n#' @param member A number showing which member is selected to get, if the dataset has a \"member\" dimension. Default\n#' is NULL, if no member assigned, and there is a \"member\" in dimensions, the mean value of the members will be\n#' taken.\n#' @param omitNA A boolean showing whether the missing value is omitted.\n#' @param info A boolean showing whether the information of the map, e.g., max, mean ..., default is FALSE.\n#' @param ... \\code{title, x, y} showing the title and x and y axis of the plot. e.g. \\code{title = 'aaa'}\n#' @details\n#' There are following methods to be selected, \n#' \"annual\": annual rainfall of each year is plotted.  \n#' \"winter\", \"spring\", \"autumn\", \"summer\": seasonal rainfall of each year is plotted.\n#' Month(number 1 to 12): month rainfall of each year is plotted, e.g. march rainfall of each year.\n#' \"meanMonthly\": the mean monthly rainfall of each month over the whole period.\n#' \n#' #Since \"winter\" is a crossing year, 12, 1, 2, 12 is in former year, and 1, 2 are in latter year.\n#' #so winter belongs to the latter year.\n#' \n#' \n#' \\code{cell} representing the location of the cell, NOTE: this location means the index of the cell,\n#' IT IS NOT THE LONGITUDE AND LATITUDE. e.g., \\code{cell = c(2, 3)}, the program will take the 2nd longitude\n#' and 3rd latitude, by the increasing order. Longitude comes first.\n#' \n#' \n#' It is a generic function, if in your case you need to debug, please see \\code{?debug()} \n#' for how to debug S4 method.\n#' \n#' @examples\n#' #gridData provided by package is the result of \\code{loadNcdf()}\n#' data(tgridData)\n#' b1 <- getPreciBar(tgridData, method = 'annual')\n#' b2 <- getPreciBar(tgridData, method = 'meanMonthly')\n#' \n#' data(testdl)\n#' TS  <- testdl[[1]]\n#' a <- getPreciBar(TS, method = 'spring')\n#' # if info = T, the information will be given at the bottom.\n#' a <- getPreciBar(TS, method = 'spring', info = TRUE)\n#' \n#' \n#' # More examples can be found in the user manual on http:https://yuanchao-xu.github.io/hyfo/\n#' \n#' @references \n#' \n#' \n#' \\itemize{\n#' \\item Hadley Wickham (2007). Reshaping Data with the reshape Package. Journal of Statistical Software,\n#' 21(12), 1-20. URL http:https://www.jstatsoft.org/v21/i12/.\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n#' \\item R Core Team (2015). R: A language and environment for statistical computing. R Foundation for\n#' Statistical Computing, Vienna, Austria. URL http:https://www.R-project.org/.\n#' }\n#'\n#' \n#' @return The calculated mean value of the input time series and the plot of the result.\n#' @export\nsetGeneric('getPreciBar', function(data, method, cell = 'mean', output = 'data', name = NULL, \n                                   plotRange = TRUE, member = NULL, omitNA = TRUE, info = FALSE,\n                                   ...) {\n  standardGeneric('getPreciBar')\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('list'), \n          function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n            TS <- getPreciBar.list(data, cell, member)\n            # for hyfo file, in order to process the data, year and month index need to be provided.\n            startTime <- as.POSIXlt(data$Dates$start, tz = 'GMT')\n            yearIndex <- startTime$year + 1900\n            monthIndex <- startTime$mon + 1\n            \n            result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, yearIndex,\n                                       monthIndex, ...)\n            return(result)\n})\n\n#' @rdname getPreciBar\nsetMethod('getPreciBar', signature('data.frame'), \n          function(data, method, cell, output, name, plotRange, member, omitNA, info, ...) {\n            Date <- as.POSIXlt(TS[, 1])\n            yearIndex <- Date$year + 1900\n            monthIndex <- Date$mon + 1\n            TS <- getPreciBar.TS(data)\n            result <- getPreciBar.plot(TS, method, output, name, plotRange, omitNA, info, \n                                       yearIndex, monthIndex, ...)\n            return(result)\n})\n\n\ngetPreciBar.list <- function(dataset, cell, member) {\n  #check input dataset\n  checkHyfo(dataset)\n  \n  data <- dataset$Data\n  \n  # Dimension needs to be arranged. Make sure first and second dimension is lat and lon.\n  data <- adjustDim(data, ref = c('lon', 'lat', 'time'))\n  \n  # Because in the following part, only 3 dimensions are allowed, so data has to be processed.\n  if (is.null(member) & any(attributes(data)$dimensions == 'member')) {\n    dimIndex3 <- which(attributes(data)$dimensions != 'member')\n    data <- apply(data, MARGIN = dimIndex3, FUN = mean, na.rm = TRUE)\n  } else if (!is.null(member) & any(attributes(data)$dimensions == 'member')) {\n    dimIndex3 <- which(attributes(data)$dimensions == 'member')\n    data <- chooseDim(data, dimIndex3, member, drop = TRUE)\n  } else if (!is.null(member) & !any(attributes(data)$dimensions == 'member')){\n    stop('There is no member part in the dataset, but you choose one, check the input\n         dataset or change your arguments.')\n  }\n  \n  if (identical(cell, 'mean')) {\n    TS <- apply(data, MARGIN = 3, FUN = mean, na.rm = TRUE) \n  } else {\n    TS <- data[cell[1], cell[2], ]\n  }\n  \n  return(TS)\n}\n\n\n#' @importFrom reshape2 melt\ngetPreciBar.TS <- function(TS) {\n  \n#  Date <- as.POSIXlt(TS[, 1])\n#  yearIndex <- Date$year + 1900\n#  monthIndex <- Date$mon + 1\n  n <- ncol(TS) - 1\n  \n  if ( n == 1) {\n    TS <- TS[, 2]\n  } else {\n    \n    TS <- TS[, -1]\n    # month index should be repeat, but years cannot.\n#    yearIndex <- sapply(1:n, function(x) yearIndex + x - 1)\n#    dim(yearIndex) <- c(n * nrow(yearIndex), 1)\n    \n#    monthIndex <- rep(monthIndex, n)\n    TS <- melt(TS)[, 2]\n    \n  }\n  return(TS)\n}\n\n\n#' @importFrom stats median\n#' @importFrom reshape2 melt\n#' @import ggplot2\ngetPreciBar.plot <- function(TS, method, output, name, plotRange, omitNA, info, \n                             yearIndex = NULL, monthIndex = NULL, ...) {\n  \n  \n  if (method == 'meanMonthly') {\n    \n    monthlyPreci <- tapply(TS, INDEX = list(yearIndex, monthIndex), FUN = sum, na.rm = omitNA)\n    meanMonthlyPreci <- apply(monthlyPreci, MARGIN = 2, FUN = mean, na.rm = TRUE)\n    \n    \n    title <- 'Mean Monthly Precipitation'\n    xlab <- 'Month'\n    \n    plotPreci <- data.frame(Index = month.abb[as.numeric(colnames(monthlyPreci))], \n                            Preci = meanMonthlyPreci)\n    \n    # Here factor has to be reassigned, to keep the original order, or it will be reordered.\n    plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n    \n    if (plotRange) {\n      maxValue <- apply(monthlyPreci, MARGIN = 2, FUN = max, na.rm = TRUE)\n      minValue <- apply(monthlyPreci, MARGIN = 2, FUN = min, na.rm = TRUE)\n      \n      plotPreci$maxValue <- maxValue\n      plotPreci$minValue <- minValue\n      \n      ylim <- c(0,max(maxValue, na.rm = TRUE) * 1.1)\n      \n    } else {\n      ylim <- c(0,max(meanMonthlyPreci, na.rm = TRUE) * 1.1)\n    }\n    \n    \n  } else if (method == 'annual') {  \n    \n    if (length(unique(monthIndex)) < 12) {\n      warning ('There are less than 12 months in a year, the results may be inaccurate.')\n    }\n    \n    annualPreci <- tapply(TS, INDEX = yearIndex, FUN = sum, na.rm = TRUE)\n    title <- 'Annual Precipitation'\n    xlab <- 'Year'\n    plotName <- names(annualPreci)\n    \n    plotPreci <- data.frame(Index = names(annualPreci), Preci = annualPreci)\n    plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n    \n    ylim <- c(0, max(annualPreci, na.rm = TRUE) * 1.1)\n    \n  } else if (is.numeric(method)) {\n    month <- method\n    monExisting <- length(which(unique(monthIndex) == month))\n    if (monExisting == 0) stop(\"Your input month doesn't exist in the dataset.\")\n    \n    monthlyPreci <- getMeanPreci(TS, method = month, yearIndex = yearIndex,\n                                 monthIndex = monthIndex, fullResults = TRUE, omitNA = omitNA)\n    # If monthlyPreci length is 1, names need to be added.\n    if (length(monthlyPreci) == 1) names(monthlyPreci) <- unique(yearIndex)\n    plotPreci <- data.frame(Index = names(monthlyPreci), Preci = monthlyPreci)\n    plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n    \n    title <- paste(month.abb[month], 'Precipitation over Whole Period', sep = ' ')\n    xlab <- 'Year'\n    ylim <- c(0, max(monthlyPreci, na.rm = TRUE) * 1.1)\n    \n  } else if (method == 'spring') {   \n    \n    wm <- match(c(3, 4, 5), unique(monthIndex))\n    if (length(which(!is.na(wm))) < 3) {\n      stop('Spring has less than 3 months, check data and try to calculate every month\n           seperately or choose another season.')\n    }\n    \n    seasonalPreci <- getMeanPreci(TS, method = 'spring', yearIndex = yearIndex,\n                                  monthIndex = monthIndex, fullResults = TRUE, omitNA = omitNA)\n    plotPreci <- data.frame(Index = names(seasonalPreci), Preci = seasonalPreci)\n    plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n    \n    title <- paste('Spring', 'Precipitation over Whole Period', sep = ' ')\n    xlab <- 'Year'\n    ylim <- c(0, max(seasonalPreci, na.rm = TRUE) * 1.1)\n    \n    \n    } else if (method == 'summer') {\n      \n      wm <- match(c(6, 7, 8), unique(monthIndex))\n      if (length(which(!is.na(wm))) < 3) {\n        stop('Summer has less than 3 months, check data and try to calculate every month\n             seperately or choose another season.')\n      }\n      \n      seasonalPreci <- getMeanPreci(TS, method = 'summer', yearIndex = yearIndex,\n                                    monthIndex = monthIndex, fullResults = TRUE, omitNA = omitNA)\n      plotPreci <- data.frame(Index = names(seasonalPreci), Preci = seasonalPreci)\n      plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n      \n      title <- paste('Summer', 'Precipitation over Whole Period', sep = ' ')\n      xlab <- 'Year'\n      ylim <- c(0, max(seasonalPreci, na.rm = TRUE) * 1.1)\n      \n      \n      } else if (method == 'autumn') {\n        wm <- match(c(9, 10, 11), unique(monthIndex))\n        if (length(which(!is.na(wm))) < 3) {\n          stop('Autumn has less than 3 months, check data and try to calculate every month\n               seperately or choose another season.')\n        }\n        \n        seasonalPreci <- getMeanPreci(TS, method = 'autumn', yearIndex = yearIndex,\n                                      monthIndex = monthIndex, fullResults = TRUE, omitNA = omitNA)\n        plotPreci <- data.frame(Index = names(seasonalPreci), Preci = seasonalPreci)\n        plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n        \n        title <- paste('Autumn', 'Precipitation over Whole Period', sep = ' ')\n        xlab <- 'Year'\n        ylim <- c(0, max(seasonalPreci, na.rm = TRUE) * 1.1)\n        \n        } else if (method == 'winter') {\n          wm <- match(c(12, 1, 2), unique(monthIndex))\n          if (length(which(!is.na(wm))) < 3) {\n            stop('Winter has less than 3 months, check data and try to calculate every month\n                 seperately or choose another season.')\n          }\n          \n          seasonalPreci <- getMeanPreci(TS, method = 'winter', yearIndex = yearIndex,\n                                        monthIndex = monthIndex, fullResults = TRUE, omitNA = omitNA)\n          plotPreci <- data.frame(Index = names(seasonalPreci), Preci = seasonalPreci)\n          plotPreci$Index <- factor(plotPreci$Index, levels = plotPreci$Index, ordered = TRUE)\n          \n          title <- paste('Winter', 'Precipitation over Whole Period', sep = ' ')\n          xlab <- 'Year'\n          ylim <- c(0, max(seasonalPreci, na.rm = TRUE) * 1.1)\n          \n          } else {\n            stop(paste('No method called \"', method, '\", check help for information'))\n          }\n  \n  \n  xlim <- c(0, length(rownames(plotPreci))) \n  \n  if (info == TRUE) {\n    meanValue <- round(mean(plotPreci$Preci, na.rm = TRUE), 2)\n    medianValue <- round(median(plotPreci$Preci,na.rm = TRUE), 2)\n    plotMean <- paste('Mean', ' = ', meanValue)\n    plotMedian <- paste('Median', ' = ', medianValue)\n    \n    plotMax <- round(max(plotPreci$Preci, na.rm = TRUE), 2)\n    plotMin <- round(min(plotPreci$Preci, na.rm = TRUE), 2)\n    word <- paste('\\n\\n', paste(' Max', '=', plotMax), ',', paste('Min', '=', plotMin), ',',\n                  plotMean, ',', plotMedian)\n  } else word <- NULL\n  \n  \n  xlab <- paste(xlab, word)\n  \n  theme_set(theme_bw())\n  \n  mainLayer <- with(plotPreci, {\n    ggplot(plotPreci) +\n      geom_bar(aes(x = Index, y = Preci), stat = 'identity', colour = 'black', fill = 'cyan2', width = rel(.4)) +\n      xlab(xlab) +\n      ylab('Precipitation (mm)') +\n      ggtitle(title) +\n      labs(empty = NULL, ...) +#in order to pass \"...\", arguments shouldn't be empty.\n      theme(plot.title = element_text(size = rel(1.6), face = 'bold'),\n            axis.title.x = element_text(size = rel(1.6)),\n            axis.title.y = element_text(size = rel(1.6)),\n            axis.text.x = element_text(angle = 90, hjust = 1, size = rel(1.9)),\n            axis.text.y = element_text(size = rel(1.9)))\n    #    geom_text(x = min(xlim) + 0.95 * (max(xlim) - min(xlim)), y = min(ylim) + 0.15 * (max(ylim) - min(ylim)),\n    #              label = word)+\n    #     geom_hline(yintercept = meanValue) +\n    #     geom_text(x = min(xlim) + 0.3 * (max(xlim) - min(xlim)), y = meanValue + 3, vjust = 0, label = 'mean') +\n    #     geom_hline(yintercept = medianValue, colour = 'red') +\n    #     geom_text(x = min(xlim) + 0.6 * (max(xlim) - min(xlim)), y = medianValue + 3, vjust = 0,\n    #               label = 'median', colour = 'red')\n  })\n  \n  \n  if (plotRange) {\n    if (is.null(plotPreci$maxValue)) {\n      message('There is no plotRange for this method')\n      print(mainLayer)\n    } else {\n      rangeLayer <- with(plotPreci, {\n        geom_errorbar(aes(x = Index, ymax = maxValue, ymin = minValue), width = rel(0.3))\n      })       \n      print(mainLayer + rangeLayer)\n    }\n    \n  } else {\n    print(mainLayer)\n  } \n  \n  if (output == 'plot') {\n    return(mainLayer)\n  } else if (output == 'ggplot') {\n    if (is.null(name)) stop('\"name\" argument not found, \n                            If you choose \"ggplot\" as output, please assign a name.')\n    plotPreci$Name <- rep(name, dim(plotPreci)[1])\n    return(plotPreci)\n  } else {\n    return(plotPreci)\n  }\n}\n\n\n\n\n\n\n\n#' Combine bars together\n#' @param ... different barplots generated by \\code{getPreciBar(, output = 'ggplot')}, refer to details.\n#' @details\n#' ..., representing different ouput generated by \\code{getPreciBar(, output = 'ggplot')}, they \n#' have to be of the same type, e.g., \n#' 1. Jan precipitation of different years, Feb precipitation of different years, and... \n#' They are both monthly precipitation, and they share x axis.\n#' \n#' 2. Mean monthly precipitation of different dataset. e.g., long term mean monthly precipitation\n#' and short term mean monthly precipitation. They are both mean monthly precipitation.\n#' \n#' @param nrow A number showing the number of rows.\n#' @param list If input is a list containing different ggplot data, use l\\code{list = inputlist}.\n#' NOTE: yOU HAVE TO PUT A \\code{list = }, before your list.\n#' @param x A string of x axis name.\n#' @param y A string of y axis name.\n#' @param title A string of the title.\n#' @param output A boolean, if chosen TRUE, the output will be given.\n#' @return A combined barplot.\n#' @examples\n#' \n#' data(tgridData)# the result of \\code{\\link{loadNcdf}}\n#' #output type of getPreciBar() has to be 'ggplot'.\n#' b1 <- getPreciBar(tgridData, method = 2, output = 'ggplot', name = 'b1')\n#' b2 <- getPreciBar(tgridData, method = 3, output = 'ggplot', name = 'b2')\n#' \n#' getPreciBar_comb(b1, b2)\n#' \n#' # More examples can be found in the user manual on http:https://yuanchao-xu.github.io/hyfo/\n#' \n#' @export\n#' @import ggplot2\n#' @importFrom data.table rbindlist\n#' @references \n#' \n#' \\itemize{\n#' \\item H. Wickham. ggplot2: elegant graphics for data analysis. Springer New York, 2009.\n#' }\n#' \ngetPreciBar_comb <- function(..., list = NULL, nrow = 1, x = '', y = '', title = '', output = FALSE) {\n  if (!is.null(list)) {\n    data_ggplot <- rbindlist(list)\n  } else {\n    \n    bars <- list(...)\n    checkBind(bars, 'rbind')\n    data_ggplot <- rbindlist(bars)\n  }\n  \n  if (!class(data_ggplot)[1] == 'data.table') {\n    warning('Your input is probably a list, but you forget to add \"list = \" before it.\n            Try again, or check help for more information.')\n  } else if (is.null(data_ggplot$Name)) {\n    stop('No \"Name\" column in the input data, check the arguments in getPreciBar(), if \n         output = \"ggplot\" is assigned, more info please check ?getPreciBar.')\n  }\n  \n  data_ggplot$Name <- factor(data_ggplot$Name, levels = unique(data_ggplot$Name), ordered = TRUE)\n  \n  theme_set(theme_bw())\n  \n  mainLayer <- with(data_ggplot, {\n    ggplot(data_ggplot) +\n      geom_bar(aes(x = Index, y = Preci),fill = 'cyan2', stat = 'identity', \n               colour = 'black', width = rel(.4)) +\n      facet_wrap( ~ Name, nrow = nrow) +\n      theme(plot.title = element_text(size = rel(1.6), face = 'bold'),\n            axis.title.x = element_text(size = rel(1.6)),\n            axis.title.y = element_text(size = rel(1.6)),\n            axis.text.x = element_text(angle = 90, hjust = 1, size = rel(1.9)),\n            axis.text.y = element_text(size = rel(1.9))) +\n      labs(x = x, y = y, title = title)\n  })\n  \n  if (!any(is.na(match(c('minValue', 'maxValue'), colnames(data_ggplot))))) {\n    rangeLayer <- with(data_ggplot, {\n      geom_errorbar(aes(x = Index, ymax = maxValue, ymin = minValue), width = rel(0.3))\n    })       \n    mainLayer <- mainLayer + rangeLayer\n  }\n  \n  \n  suppressWarnings(print(mainLayer))\n  \n  if (output == TRUE) return(data_ggplot)\n  }\n\n",
    "created" : 1483876772702.000,
    "dirty" : false,
    "encoding" : "ASCII",
    "folds" : "",
    "hash" : "3525032847",
    "id" : "6DDA2A7B",
    "lastKnownWriteTime" : 1487522678,
    "last_content_update" : 1487522678570,
    "path" : "~/GitHub/hyfo/R/getPreciBar(generic).R",
    "project_path" : "R/getPreciBar(generic).R",
    "properties" : {
    },
    "relative_order" : 7,
    "source_on_save" : false,
    "source_window" : "",
    "type" : "r_source"
}